diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +0.3.1 (2025-08-13) +------------------ + +- Update bounds for compatibility with ghc-9.10 +- Add `hasCycle` for detecting cycles in graphs (@kquick) +- Optimize DFS algorithms by removing an unnecessary traversal (@kquick) + 0.3 (2023-08-20) ---------------- diff --git a/bench/HaggleBench.hs b/bench/HaggleBench.hs new file mode 100644 --- /dev/null +++ b/bench/HaggleBench.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +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 --- a/haggle.cabal +++ b/haggle.cabal @@ -1,5 +1,5 @@ name: haggle -version: 0.3 +version: 0.3.1 synopsis: A graph library offering mutable, immutable, and inductive graphs description: This library provides mutable (in ST or IO), immutable, and inductive graphs. There are multiple graphs implementations provided to support different use @@ -16,7 +16,7 @@ category: Data Structures, Graphs build-type: Simple cabal-version: >=1.10 -tested-with: GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.5 || ==0.6.2 +tested-with: GHC ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || == 9.8.2 || == 9.10.1 extra-source-files: ChangeLog.md README.md @@ -45,9 +45,9 @@ ref-tf >= 0.4 && < 0.6, vector >= 0.9 && < 0.14, vector-th-unbox >= 0.2.1.3 && < 0.3, - primitive >= 0.4 && < 0.9, + primitive >= 0.4 && < 0.10, containers >= 0.4, - hashable >= 1.2 && < 1.5, + hashable >= 1.2 && < 1.6, deepseq >= 1 && < 2 test-suite GraphTests @@ -66,6 +66,23 @@ test-framework, 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.7 + , containers + , deepseq + , fgl >= 5.8.1.1 + if impl(ghc >= 8.4) + buildable: True + else + buildable: False source-repository head type: git diff --git a/src/Data/Graph/Haggle/Algorithms/DFS.hs b/src/Data/Graph/Haggle/Algorithms/DFS.hs --- a/src/Data/Graph/Haggle/Algorithms/DFS.hs +++ b/src/Data/Graph/Haggle/Algorithms/DFS.hs @@ -40,10 +40,11 @@ isConnected, topsort, scc, - reachable + reachable, + hasCycle ) where -import Control.Monad ( filterM, foldM, liftM ) +import Control.Monad ( foldM ) import Control.Monad.ST import qualified Data.Foldable as F import Data.Monoid @@ -66,22 +67,23 @@ -> [c] xdfsWith g nextVerts f roots | isEmpty g || null roots = [] - | otherwise = runST $ do - bs <- newBitSet (maxVertexId g + 1) - res <- foldM (go bs) [] roots - return $ reverse res + | otherwise = + if any (not . (`elem` vertices g)) roots + then [] + else runST $ do + bs <- newBitSet (maxVertexId g + 1) + res <- foldM (go bs) [] roots + return $ reverse res where go bs acc v = do - isMarked <- testBit bs (vertexId v) + isMarked <- testBitUnsafe bs (vertexId v) case isMarked of True -> return acc False -> do - setBit bs (vertexId v) - nxt <- filterM (notVisited bs) (nextVerts v) + setBitUnsafe bs (vertexId v) + let nxt = nextVerts v foldM (go bs) (f v : acc) nxt -notVisited :: BitSet s -> Vertex -> ST s Bool -notVisited bs v = liftM not (testBit bs (vertexId v)) -- | Forward parameterized DFS dfsWith :: (Graph g) @@ -129,18 +131,21 @@ -> [Tree c] xdffWith g nextVerts f roots | isEmpty g || null roots = [] - | otherwise = runST $ do - bs <- newBitSet (maxVertexId g + 1) - res <- foldM (go bs) [] roots - return $ reverse res + | otherwise = + if any (not . (`elem` vertices g)) roots + then [] + else runST $ do + bs <- newBitSet (maxVertexId g + 1) + res <- foldM (go bs) [] roots + return $ reverse res where go bs acc v = do - isMarked <- testBit bs (vertexId v) + isMarked <- testBitUnsafe bs (vertexId v) case isMarked of True -> return acc False -> do - setBit bs (vertexId v) - nxt <- filterM (notVisited bs) (nextVerts v) + setBitUnsafe bs (vertexId v) + let nxt = nextVerts v ts <- foldM (go bs) [] nxt return $ T.Node (f v) (reverse ts) : acc @@ -193,6 +198,13 @@ -- | Compute the set of vertices reachable from a root 'Vertex'. reachable :: (Graph g) => Vertex -> g -> [Vertex] reachable v g = preorderF (dff g [v]) + + +-- | Returns true if the current node is part of a cycle (i.e. itself is +-- reachable by a path starting with one or more of this vertex's out edges). +hasCycle :: (Graph g) => Vertex -> g -> Bool +hasCycle v g = any (\v' -> v `elem` (reachable v' g)) $ successors g v + -- Helpers diff --git a/src/Data/Graph/Haggle/Algorithms/Dominators.hs b/src/Data/Graph/Haggle/Algorithms/Dominators.hs --- a/src/Data/Graph/Haggle/Algorithms/Dominators.hs +++ b/src/Data/Graph/Haggle/Algorithms/Dominators.hs @@ -51,7 +51,9 @@ immediateDominators :: (Graph g) => g -> Vertex -> [(Vertex, Vertex)] immediateDominators g root = fromMaybe [] $ do (res, toNode, _) <- domWork g root - return $ tail $ V.toList $ V.imap (\i n -> (toNode!i, toNode!n)) res + case V.toList $ V.imap (\i n -> (toNode!i, toNode!n)) res of + [] -> error "Impossible: a vertex always dominates itself" + _ : rest -> return rest -- | Compute all of the dominators for each 'Vertex' reachable from the @root@. -- Each reachable 'Vertex' is paired with the list of nodes that dominate it, @@ -66,38 +68,43 @@ [(n, verts) | n <- rest] domWork :: (Graph g) => g -> Vertex -> Maybe (IDom, ToNode, FromNode) -domWork g root - | null trees = Nothing - | otherwise = return (idom, toNode, fromNode) +domWork g root = + -- Build up a depth-first tree from the root as a first approximation + case dff g [root] of + [] -> Nothing + [tree] -> + let (s, ntree) = numberTree 0 tree + -- Start with an approximation (idom0) where the idom of each node is + -- its parent in the depth-first tree. Note that index 0 is the root, + -- which we will basically be ignoring (since it has no dominator). + dom0Map = M.fromList (treeEdges (-1) ntree) + idom0 = V.generate (M.size dom0Map) (dom0Map M.!) + -- Build a mapping from graph vertices to internal indices. @treeNodes@ + -- are nodes that are in the depth-first tree from the root. @otherNodes@ + -- are the rest of the nodes in the graph, mapped to -1 (since they aren't + -- going to be in the result) + treeNodes = M.fromList $ zip (T.flatten tree) (T.flatten ntree) + otherNodes = M.fromList $ zip vlist (repeat (-1)) + fromNode = M.unionWith const treeNodes otherNodes + + -- Translate from internal nodes back to graph nodes (only need the nodes + -- in the depth-first tree) + toNodeMap = M.fromList $ zip (T.flatten ntree) (T.flatten tree) + toNode = V.generate (M.size toNodeMap) (toNodeMap M.!) + + -- Use a pre-pass over the graph to collect predecessors so that we don't + -- require a Bidirectional graph. We need a linear pass over the graph + -- here anyway, so we don't lose anything. + predMap = fmap S.toList $ foldr (toPredecessor g) M.empty vlist + preds = V.fromList $ [0] : [filter (/= -1) (map (fromNode M.!) (predMap M.! (toNode ! i))) + | i <- [1..s-1]] + + + idom = fixEq (refineIDom preds) idom0 + in return (idom, toNode, fromNode) + _trees -> error "Impossible: only a single tree can be reachable starting from a single root node" where vlist = reachable root g - -- Build up a depth-first tree from the root as a first approximation - trees@(~[tree]) = dff g [root] - (s, ntree) = numberTree 0 tree - -- Start with an approximation (idom0) where the idom of each node is - -- its parent in the depth-first tree. Note that index 0 is the root, - -- which we will basically be ignoring (since it has no dominator). - dom0Map = M.fromList (treeEdges (-1) ntree) - idom0 = V.generate (M.size dom0Map) (dom0Map M.!) - -- Build a mapping from graph vertices to internal indices. @treeNodes@ - -- are nodes that are in the depth-first tree from the root. @otherNodes@ - -- are the rest of the nodes in the graph, mapped to -1 (since they aren't - -- going to be in the result) - treeNodes = M.fromList $ zip (T.flatten tree) (T.flatten ntree) - otherNodes = M.fromList $ zip vlist (repeat (-1)) - fromNode = M.unionWith const treeNodes otherNodes - -- Translate from internal nodes back to graph nodes (only need the nodes - -- in the depth-first tree) - toNodeMap = M.fromList $ zip (T.flatten ntree) (T.flatten tree) - toNode = V.generate (M.size toNodeMap) (toNodeMap M.!) - - -- Use a pre-pass over the graph to collect predecessors so that we don't - -- require a Bidirectional graph. We need a linear pass over the graph - -- here anyway, so we don't lose anything. - predMap = fmap S.toList $ foldr (toPredecessor g) M.empty vlist - preds = V.fromList $ [0] : [filter (/= -1) (map (fromNode M.!) (predMap M.! (toNode ! i))) - | i <- [1..s-1]] - idom = fixEq (refineIDom preds) idom0 toPredecessor :: (Graph g) => g diff --git a/src/Data/Graph/Haggle/Classes.hs b/src/Data/Graph/Haggle/Classes.hs --- a/src/Data/Graph/Haggle/Classes.hs +++ b/src/Data/Graph/Haggle/Classes.hs @@ -219,6 +219,7 @@ return g' addEdgeLabel :: (HasEdgeLabel g) => g -> Edge -> (Edge, EdgeLabel g) -addEdgeLabel g e = (e, el) - where - Just el = edgeLabel g e +addEdgeLabel g e = + case edgeLabel g e of + Just el -> (e, el) + Nothing -> error "Expected an edge label for a graph implementation satisfying the HasEdgeLabel constraint" diff --git a/src/Data/Graph/Haggle/Internal/Adapter.hs b/src/Data/Graph/Haggle/Internal/Adapter.hs --- a/src/Data/Graph/Haggle/Internal/Adapter.hs +++ b/src/Data/Graph/Haggle/Internal/Adapter.hs @@ -324,8 +324,9 @@ labeledVertices g = map toLabVert $ I.vertices (rawGraph g) where toLabVert v = - let Just lab = vertexLabel g v - in (v, lab) + case vertexLabel g v of + Just lab -> (v, lab) + Nothing -> error "Impossible: LabeledGraphs always have vertex labels" -- | Likewise, we use 'edges' here instead of directly reading from the edge -- label storage array. @@ -333,8 +334,9 @@ labeledEdges g = map toLabEdge $ I.edges (rawGraph g) where toLabEdge e = - let Just lab = edgeLabel g e - in (e, lab) + case edgeLabel g e of + Just lab -> (e, lab) + Nothing -> error "Impossible: LabeledGraphs always have edge labels" mapEdgeLabel :: LabeledGraph g nl el -> (el -> el') -> LabeledGraph g nl el' mapEdgeLabel g f = g { edgeLabelStore = V.map f (edgeLabelStore g) } diff --git a/src/Data/Graph/Haggle/Internal/BitSet.hs b/src/Data/Graph/Haggle/Internal/BitSet.hs --- a/src/Data/Graph/Haggle/Internal/BitSet.hs +++ b/src/Data/Graph/Haggle/Internal/BitSet.hs @@ -2,7 +2,9 @@ BitSet, newBitSet, setBit, - testBit + testBit, + setBitUnsafe, + testBitUnsafe ) where import Control.Monad.ST @@ -11,6 +13,21 @@ import qualified Data.Vector.Unboxed.Mutable as V import Data.Word ( Word64 ) +-- Note that the implementation here assumes thaththe bit numbers are all +-- unsigned. A proper implementation would perhaps use 'Natural' instead of +-- 'Int', but that would require gratuitous fromEnum/toEnum conversions from all +-- the other API's that just use 'Int', which has about a 33% performance impact +-- when measured. +-- +-- The 'setBit' and 'testBit' operations use V.unsafeRead instead of V.read +-- (where the latter is roughly 25% slower) because this is an internal module +-- that is generally always used with a positive 'Int' value, and the value is +-- also checked against 'sz' (which is also probably superfluous). In other +-- words, this module prioritizes performance over robustness and should only be +-- used when the caller can guarantee positive Int values and otherwise good +-- behavior. + + data BitSet s = BS (STVector s Word64) {-# UNPACK #-} !Int bitsPerWord :: Int @@ -28,22 +45,31 @@ -- | Set a bit in the bitset. Out of range has no effect. setBit :: BitSet s -> Int -> ST s () -setBit (BS v sz) bitIx +setBit b@(BS _ sz) bitIx | bitIx >= sz = return () - | otherwise = do + | bitIx < 0 = return () + | otherwise = setBitUnsafe b bitIx + +-- | Set a bit in the bitset. The specified bit must be in range. +setBitUnsafe :: BitSet s -> Int -> ST s () +setBitUnsafe (BS v _) bitIx = do let wordIx = bitIx `div` bitsPerWord bitPos = bitIx `mod` bitsPerWord - oldWord <- V.read v wordIx + oldWord <- V.unsafeRead v wordIx let newWord = B.setBit oldWord bitPos V.write v wordIx newWord -- | Return True if the bit is set. Out of range will return False. testBit :: BitSet s -> Int -> ST s Bool -testBit (BS v sz) bitIx +testBit b@(BS _ sz) bitIx | bitIx >= sz = return False - | otherwise = do + | bitIx < 0 = return False + | otherwise = testBitUnsafe b bitIx + +-- | Return True if the bit is set. The specified bit must be in range. +testBitUnsafe :: BitSet s -> Int -> ST s Bool +testBitUnsafe (BS v _) bitIx = do let wordIx = bitIx `div` bitsPerWord bitPos = bitIx `mod` bitsPerWord - w <- V.read v wordIx + w <- V.unsafeRead v wordIx return $ B.testBit w bitPos - diff --git a/src/Data/Graph/Haggle/PatriciaTree.hs b/src/Data/Graph/Haggle/PatriciaTree.hs --- a/src/Data/Graph/Haggle/PatriciaTree.hs +++ b/src/Data/Graph/Haggle/PatriciaTree.hs @@ -79,8 +79,10 @@ labeledEdges gr = map toLabEdge (I.edges gr) where toLabEdge e = - let Just lab = I.edgeLabel gr e - in (e, lab) + case I.edgeLabel gr e of + Just lab -> (e, lab) + Nothing -> error "Impossible: PatriciaTree instances always have edge labels" + labeledOutEdges (Gr g) (I.V s) = fromMaybe [] $ do Ctx _ _ _ ss <- IM.lookup s g return $ IM.foldrWithKey toOut [] ss @@ -95,8 +97,9 @@ labeledVertices gr = map toLabVert (I.vertices gr) where toLabVert v = - let Just l = I.vertexLabel gr v - in (v, l) + case I.vertexLabel gr v of + Just l -> (v, l) + Nothing -> error "Impossible: PatriciaTree instances always have vertex labels" instance I.Bidirectional (PatriciaTree nl el) where predecessors (Gr g) (I.V v) = fromMaybe [] $ do diff --git a/tests/GraphTests.hs b/tests/GraphTests.hs --- a/tests/GraphTests.hs +++ b/tests/GraphTests.hs @@ -1,5 +1,11 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | This module tests Haggle by comparing its results to those of FGL. -- This assumes that FGL is reasonably correct. @@ -20,6 +26,7 @@ import Control.Arrow ( first, second ) import qualified Data.Bifunctor as Bi import Control.Monad ( replicateM ) +import Data.Function ( on ) import qualified Data.Foldable as F import qualified Data.List as L import Data.Maybe ( fromJust, isNothing ) @@ -31,8 +38,6 @@ import qualified Data.Graph.Inductive as FGL import qualified Data.Graph.Haggle as HGL -import qualified Data.Graph.Haggle.VertexLabelAdapter as HGL -import qualified Data.Graph.Haggle.SimpleBiDigraph as HGL import qualified Data.Graph.Haggle.Algorithms.DFS as HGL import qualified Data.Graph.Haggle.Algorithms.Dominators as HGL @@ -59,6 +64,8 @@ i <- choose (0, n) return (NID i) +-- | Generates a pair of a Haggle graph and the corresponding FGL graph to serve +-- as an oracle. mkGraphPair :: Int -> Gen GraphPair mkGraphPair sz = do nEdges <- choose (2, 2 * sz) @@ -71,6 +78,8 @@ (tg, _) = HGL.fromEdgeList HGL.newMSimpleBiDigraph edges return $! GP edges bg tg + + main :: IO () main = defaultMain tests @@ -88,6 +97,11 @@ -- dom functionality that is used as the oracle for the tests here. , testProperty "prop_dominatorsSame" prop_dominatorsSame + , testProperty "patricia match: remaining vertices" prop_match_patricia_remvertices + , testProperty "patricia match: vertex label removed" prop_match_patricia_vlblremoved + , testProperty "patricia match: disconnected to" prop_match_patricia_no_in_edges + , testProperty "patricia match: disconnected from" prop_match_patricia_no_out_edges + , testProperty "patricia match: edges removed" prop_match_patricia_remedges ] <> testPatricia <> testExplicit @@ -202,7 +216,17 @@ , "haggle (patricia) [2-1,2-2] reachable from 1" ~: do HGL.reachable (vs !! 0) gr2 @?= [ (vs !! 0) ] + , "no cycle in [1-2,4] from 1" ~: + do HGL.hasCycle (vs !! 0) gr1 @?= False + , "cycle in [1-2-1,4] from 1" ~: + do let tg = plusEdge gr1 (vs !! 1) (vs !! 0) + HGL.hasCycle (vs !! 0) tg @?= True + + , "cycle in [1*-2,4] from 1" ~: + do let tg = plusEdge gr1 (vs !! 0) (vs !! 0) + HGL.hasCycle (vs !! 0) tg @?= True + , "haggle dominator [1-2,4] from 1" ~: do HGL.dominators gr1 (vs !! 0) @?= [ (vs !! 0, [ (vs !! 0) ]) , (vs !! 1, [ (vs !! 1), (vs !! 0) ]) @@ -242,15 +266,15 @@ testPatricia :: [Test.Framework.Test] testPatricia = let gr0 = foldl (\g -> snd . HGL.insertLabeledVertex g) - (HGL.emptyGraph :: HGL.PatriciaTree Int Char) - [1,2,4,3,5,0] - vs = fst <$> HGL.labeledVertices gr0 + (HGL.emptyGraph :: HGL.PatriciaTree Int Char) + [1,2,4,3,5,0] + vs = fst <$> (L.sortBy (compare `on` snd) $ HGL.labeledVertices gr0) gr1 = foldl (\g (f,t,l) -> snd $ fromJust $ HGL.insertLabeledEdge g f t l) gr0 - [ (vs !! 1, vs !! 2, 'a') - , (vs !! 0, vs !! 2, 'b') - , (vs !! 1, vs !! 5, 'c') + [ (vs !! 2, vs !! 4, 'a') + , (vs !! 1, vs !! 4, 'b') + , (vs !! 2, vs !! 0, 'c') ] in hUnitTestToTests $ test [ "create graph" ~: @@ -273,9 +297,153 @@ L.sort (snd <$> HGL.labeledEdges gr2) @?= "cde" , "replaceLabeledVertex" ~: - do let gr2 = HGL.replaceLabeledVertex gr1 (vs !! 2) 11 + do let gr2 = HGL.replaceLabeledVertex gr1 (vs !! 4) 11 -- Vertex label changed? sum (snd <$> HGL.labeledVertices gr2) @?= (15 + (11 - 4)) -- Edges are still in place? L.sort (snd <$> HGL.labeledEdges gr2) @?= "abc" ] + + +---------------------------------------------------------------------- + + +newtype NodeLabel = NL Int deriving (Eq, Show) +newtype EdgeLabel = EL Int deriving (Eq, Show) + +-- type InductiveGraphBuilder g = (g NodeLabel EdgeLabel -> g NodeLabel EdgeLabel) +data InductiveGraphBuilder g = + IGB { build :: g NodeLabel EdgeLabel -> g NodeLabel EdgeLabel } + +instance ( HGL.InductiveGraph (g NodeLabel EdgeLabel) + , HGL.HasVertexLabel (g NodeLabel EdgeLabel) + , HGL.HasEdgeLabel (g NodeLabel EdgeLabel) + , HGL.VertexLabel (g NodeLabel EdgeLabel) ~ NodeLabel + , HGL.EdgeLabel (g NodeLabel EdgeLabel) ~ EdgeLabel + ) => Arbitrary (InductiveGraphBuilder g) where + arbitrary = oneof [ solitaryNode + , edgeToNewNode + , edgeBetweenExistingNodes + , edgeToSelf + ] + where solitaryNode = return $ IGB $ \g -> + let vLabel = NL $ length $ HGL.vertices g + in snd $ HGL.insertLabeledVertex g vLabel + edgeToNewNode = do + srcNum <- choose (0, 1024) + return $ IGB $ \g -> + let vs = HGL.vertices g + srcV = cycle vs !! srcNum + vLabel = NL $ length $ vs + eLabel = EL $ length $ HGL.edges g + (nv, ng) = HGL.insertLabeledVertex g vLabel + in if null vs + then ng + else maybe g snd $ HGL.insertLabeledEdge ng srcV nv eLabel + edgeBetweenExistingNodes = do + srcNum <- choose (0, 1024) + dstNum <- choose (0, 1024) + -- n.b. the inductive graphs don't like duplicated edges, but they + -- will just return Nothing on inserting the edge, which returns the + -- existing graph, so this duplication attempt is quietly ignored. + return $ IGB $ \g -> + let vs = HGL.vertices g + srcV = cycle (HGL.vertices g) !! srcNum + dstV = cycle (HGL.vertices g) !! dstNum + eLabel = EL $ length $ HGL.edges g + in if null vs + then snd $ HGL.insertLabeledVertex g $ NL 0 + else maybe g snd $ HGL.insertLabeledEdge g srcV dstV eLabel + edgeToSelf = do + srcNum <- choose (0, 1024) + -- see note above re: duplicate edges + return $ IGB $ \g -> + let vs = HGL.vertices g + srcV = cycle (HGL.vertices g) !! srcNum + eLabel = EL $ length $ HGL.edges g + in if null vs + then snd $ HGL.insertLabeledVertex g $ NL 0 + else maybe g snd $ HGL.insertLabeledEdge g srcV srcV eLabel + + +type InductiveProperty g = InductiveCase g -> Bool + +data InductiveCase g = IGC g HGL.Vertex deriving Show + +instance (Arbitrary g, HGL.Graph g) => Arbitrary (InductiveCase g) where + arbitrary = do g <- arbitrary + v <- elements $ HGL.vertices g + return $ IGC g v + +onMatchResult :: HGL.InductiveGraph g + => HGL.Graph g + => (g -> HGL.Vertex -> (HGL.Context g, g) -> Bool) + -> InductiveProperty g +onMatchResult prop (IGC g v) = + case HGL.match g v of + Nothing -> False + Just mr -> prop g v mr + +prop_match_inductive_remvertices :: HGL.InductiveGraph g => InductiveProperty g +prop_match_inductive_remvertices = onMatchResult $ \g -> \_ -> \(_ctxt, g') -> + length (HGL.vertices g) == length (HGL.vertices g') + 1 + +prop_match_inductive_vlblremoved :: HGL.InductiveGraph g + => Eq (HGL.VertexLabel g) + => InductiveProperty g +prop_match_inductive_vlblremoved = onMatchResult $ \_ -> \v -> \(ctxt, g') -> + let HGL.Context _ vl _ = ctxt + in not $ (v,vl) `elem` HGL.labeledVertices g' + +prop_match_inductive_no_in_edges :: HGL.InductiveGraph g + => InductiveProperty g +prop_match_inductive_no_in_edges = onMatchResult $ \_ -> \v -> \(ctxt, g') -> + let HGL.Context intos _ _ = ctxt + edgeInTo (_,sv) = v /= sv && v `elem` HGL.successors g' sv + in not $ any edgeInTo intos + +prop_match_inductive_no_out_edges :: HGL.InductiveGraph g + => HGL.Bidirectional g + => Show g + => InductiveProperty g +prop_match_inductive_no_out_edges = onMatchResult $ \_ -> \v -> \(ctxt, g') -> + let HGL.Context _ _ outs = ctxt + edgeOutTo (_,dv) = v /= dv && v `elem` HGL.predecessors g' dv + in not $ any edgeOutTo outs + +prop_match_inductive_remedges :: HGL.InductiveGraph g + => HGL.HasEdgeLabel g + => Eq (HGL.EdgeLabel g) + => InductiveProperty g +prop_match_inductive_remedges = onMatchResult $ \_ -> \_ -> \(ctxt, g') -> + let HGL.Context intos _ outs = ctxt + remainingEdgeLabels = snd <$> HGL.labeledEdges g' + hasEdge (el,_) = el `elem` remainingEdgeLabels + in not $ any hasEdge $ intos <> outs + +-------------------- + +type PatriciaProperty = InductiveProperty (HGL.PatriciaTree NodeLabel EdgeLabel) + +instance Arbitrary (HGL.PatriciaTree NodeLabel EdgeLabel) where + arbitrary = do mkGraph <- listOf1 arbitrary + return $ foldr build HGL.emptyGraph mkGraph + +instance Show (HGL.PatriciaTree NodeLabel EdgeLabel) where + show g = "PatriciaTree/" <> show (length $ HGL.vertices g) + <> "/" <> show (length $ HGL.edges g) + +prop_match_patricia_remvertices :: PatriciaProperty +prop_match_patricia_remvertices = prop_match_inductive_remvertices + +prop_match_patricia_vlblremoved :: PatriciaProperty +prop_match_patricia_vlblremoved = prop_match_inductive_vlblremoved + +prop_match_patricia_no_in_edges :: PatriciaProperty +prop_match_patricia_no_in_edges = prop_match_inductive_no_in_edges + +prop_match_patricia_no_out_edges :: PatriciaProperty +prop_match_patricia_no_out_edges = prop_match_inductive_no_out_edges + +prop_match_patricia_remedges :: PatriciaProperty +prop_match_patricia_remedges = prop_match_inductive_remedges