diff --git a/bench/HaggleBench.hs b/bench/HaggleBench.hs new file mode 100644 index 0000000..d020c24 --- /dev/null +++ b/bench/HaggleBench.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Main ( main ) where + +import Criterion.Main + +import Control.DeepSeq +import Data.Bifunctor ( bimap ) +import qualified Data.Foldable as F +import Data.Maybe ( fromJust ) +import qualified Data.Set as S + +import qualified Data.Graph.Inductive as FGL +import qualified Data.Graph.Haggle as HGL +import qualified Data.Graph.Haggle.Algorithms.DFS as HGL + + +-- | Generates a list of nodes and edges for a sample graph of the specified +-- depth (height). The root node will be 0, and every node will have "width" +-- children down to the desired depth. There are also some extra cross-level +-- edges added to keep things from being too regular. +mkEdges :: Int -> Int -> ([Int], [(Int,Int)]) +mkEdges width depth = bimap unique unique $ go [0] 0 + where go cur l = + if l >= depth then (mempty, mempty) + else let subStart i = if i == 0 then 1 else width ^ i + subStart (i-1) + subVals = [ subStart l .. ] + (subNs, subEs) = + fst $ foldr addToRoot ((mempty, mempty), subVals) cur + addToRoot r ((rnodes, redges), vals) = + let (thisSub, remSub) = splitAt width vals + thisEdges = (r,) <$> thisSub + in ((rnodes <> thisSub, redges <> thisEdges), remSub) + next = go subNs (l+1) + extra = + let esrcs = concat $ replicate width cur + etgts = [ t + | t <- drop l $ fst next + , t `mod` (width + 3) == 0 ] + in zip esrcs etgts + in (cur <> subNs <> fst next, subEs <> extra <> snd next) + + +mkFglGraph :: Int -> Int -> FGL.Gr Int () +mkFglGraph depth width = + let (nodes, edgs) = mkEdges width depth + edges = fmap (\(s,d) -> (s,d,())) edgs + in FGL.mkGraph (zip nodes nodes) edges + + +mkHaggleDiGraph :: Int -> Int + -> (HGL.Vertex, HGL.VertexLabeledGraph HGL.Digraph Int) +mkHaggleDiGraph depth width = + let (_nodes, edges) = mkEdges width depth + g = fst $ HGL.fromEdgeList HGL.newMDigraph edges + Just v = vertexFromLabel g 0 + in (v, g) + +mkHaggleBiDiGraph :: Int -> Int -> (HGL.Vertex, HGL.VertexLabeledGraph HGL.BiDigraph Int) +mkHaggleBiDiGraph depth width = + let (_nodes, edges) = mkEdges width depth + g = fst $ HGL.fromEdgeList HGL.newMBiDigraph edges + Just v = vertexFromLabel g 0 + in (v, g) + +mkHaggleSimpleBiDiGraph :: Int -> Int -> (HGL.Vertex, HGL.VertexLabeledGraph HGL.SimpleBiDigraph Int) +mkHaggleSimpleBiDiGraph depth width = + let (_nodes, edges) = mkEdges width depth + g = fst $ HGL.fromEdgeList HGL.newMSimpleBiDigraph edges + Just v = vertexFromLabel g 0 + in (v, g) + +mkHagglePatriciaGraph :: Int -> Int -> (HGL.Vertex, HGL.PatriciaTree Int ()) +mkHagglePatriciaGraph depth width = + let (nodes, edges) = mkEdges width depth + addNode g n = snd $ HGL.insertLabeledVertex g n + gnodes = foldl addNode HGL.emptyGraph nodes + addEdge g (s,d) = fromJust $ do sv <- vertexFromLabel g s + dv <- vertexFromLabel g d + (_,g') <- HGL.insertLabeledEdge g sv dv () + return g' + pgraph = foldl addEdge gnodes edges + Just v = vertexFromLabel pgraph 0 + in (v, pgraph) + + +vertexFromLabel :: HGL.HasVertexLabel g + => Eq (HGL.VertexLabel g) + => g -> HGL.VertexLabel g -> Maybe HGL.Vertex +vertexFromLabel g lbl = F.find labelMatch (HGL.vertices g) + where + labelMatch v = Just lbl == (HGL.vertexLabel g v) + +unique :: (Ord a) => [a] -> [a] +unique = S.toList . S.fromList + +testFglDFS :: FGL.Graph gr => gr a b -> [FGL.Node] +testFglDFS g = let r = FGL.dfs [0,0,0] g in if null r then error "bad fgl dfs" else r + +testHaggleDFS :: HGL.HasVertexLabel g + => Eq (HGL.VertexLabel g) + => Num (HGL.VertexLabel g) + => (HGL.Vertex, g) -> [Maybe (HGL.VertexLabel g)] +testHaggleDFS (r,g) = HGL.vertexLabel g <$> HGL.dfs g [r,r,r] + +testHaggleXDFS :: HGL.HasVertexLabel g + => Eq (HGL.VertexLabel g) + => Num (HGL.VertexLabel g) + => (HGL.Vertex, g) -> [Maybe (HGL.VertexLabel g)] +testHaggleXDFS (r,g) = HGL.vertexLabel g + <$> HGL.xdfsWith g (HGL.successors g) id [r,r,r] + +main :: IO () +main = do setup + defaultMain [ + bgroup "dfs" [ + bgroup "nf" [ + bench "fgl" $ nf testFglDFS g1f + , bench "haggle.di" $ nf testHaggleDFS g1hd + , bench "haggle.bidi" $ nf testHaggleDFS g1hbd + , bench "haggle.simplebidi" $ nf testHaggleDFS g1hsbd + , bench "haggle.patricia" $ nf testHaggleDFS g1hp + ] + ] + , bgroup "xdfs" [ + bgroup "nf" [ + bench "haggle.di" $ nf testHaggleXDFS g1hd + , bench "haggle.bidi" $ nf testHaggleXDFS g1hbd + , bench "haggle.simplebidi" $ nf testHaggleXDFS g1hsbd + , bench "haggle.patricia" $ nf testHaggleXDFS g1hp + ] + -- , bgroup "whnf" [ + -- bench "haggle.di" $ whnf testHaggleXDFS g1hd + -- , bench "haggle.bidi" $ whnf testHaggleXDFS g1hbd + -- , bench "haggle.simplebidi" $ whnf testHaggleXDFS g1hsbd + -- , bench "haggle.patricia" $ whnf testHaggleXDFS g1hp + -- ] + ] + , bgroup "topsort" [ + bgroup "nf" [ + bench "fgl" $ nf FGL.topsort g1f + , bench "haggle.di" $ nf HGL.topsort $ snd g1hd + , bench "haggle.bidi" $ nf HGL.topsort $ snd g1hbd + , bench "haggle.simplebidi" $ nf HGL.topsort $ snd g1hsbd + , bench "haggle.patricia" $ nf HGL.topsort $ snd g1hp + ] + ] + , bgroup "scc" [ + bgroup "nf" [ + bench "fgl" $ nf FGL.scc g1f + -- , bench "haggle.di" $ nf HGL.scc $ snd g1hd + , bench "haggle.bidi" $ nf HGL.scc $ snd g1hbd + , bench "haggle.simplebidi" $ nf HGL.scc $ snd g1hsbd + , bench "haggle.patricia" $ nf HGL.scc $ snd g1hp + ] + ] + , bgroup "isConnected" [ + bgroup "nf" [ + bench "fgl" $ nf FGL.isConnected g1f + -- , bench "haggle.di" $ nf HGL.isConnected $ snd g1hd + , bench "haggle.bidi" $ nf HGL.isConnected $ snd g1hbd + , bench "haggle.simplebidi" $ nf HGL.isConnected $ snd g1hsbd + , bench "haggle.patricia" $ nf HGL.isConnected $ snd g1hp + ] + ] + ] + where + setup = g1f + -- `deepseq` g1hd -- error: uninitialised element (from Vector) + -- `deepseq` g1hbd -- no instance for NFData + -- `deepseq` g1hsbd -- error: uninitialised element (from Vector) + `deepseq` g1hp + `deepseq` return () + + g1f :: FGL.Gr Int () + g1f = mkFglGraph 4 5 + + g1hd = mkHaggleDiGraph 4 5 + g1hbd = mkHaggleBiDiGraph 4 5 + g1hsbd = mkHaggleSimpleBiDiGraph 4 5 + g1hp = mkHagglePatriciaGraph 4 5 diff --git a/haggle.cabal b/haggle.cabal index 3da8297..e332141 100644 --- a/haggle.cabal +++ b/haggle.cabal @@ -67,6 +67,23 @@ test-suite GraphTests test-framework-hunit, test-framework-quickcheck2 +benchmark haggleBench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: HaggleBench.hs + hs-source-dirs: bench + ghc-options: -Wall -O2 + build-depends: haggle + , base >= 4.5 + , criterion >= 1 && < 1.6 + , containers + , deepseq + , fgl >= 5.8.1.1 + if impl(ghc >= 8.4) + buildable: True + else + buildable: False + source-repository head type: git location: https://github.com/travitch/haggle