fgl 5.7.0.3 → 5.8.3.1
raw patch · 23 files changed
Files
- ChangeLog +45/−0
- Data/Graph/Inductive/Graph.hs +11/−5
- Data/Graph/Inductive/Internal/RootPath.hs +1/−1
- Data/Graph/Inductive/Monad.hs +7/−17
- Data/Graph/Inductive/NodeMap.hs +51/−18
- Data/Graph/Inductive/PatriciaTree.hs +3/−0
- Data/Graph/Inductive/Query/BCC.hs +5/−4
- Data/Graph/Inductive/Query/BFS.hs +13/−9
- Data/Graph/Inductive/Query/Dominators.hs +23/−21
- Data/Graph/Inductive/Query/Indep.hs +7/−5
- Data/Graph/Inductive/Query/MST.hs +6/−4
- Data/Graph/Inductive/Query/MaxFlow.hs +4/−3
- Data/Graph/Inductive/Query/MaxFlow2.hs +24/−17
- Data/Graph/Inductive/Query/Monad.hs +6/−5
- Data/Graph/Inductive/Query/SP.hs +6/−4
- Data/Graph/Inductive/Query/TransClos.hs +5/−4
- Data/Graph/Inductive/Tree.hs +3/−0
- LICENSE +1/−0
- fgl-arbitrary/Data/Graph/Inductive/Arbitrary.hs +13/−12
- fgl.cabal +19/−24
- test/Data/Graph/Inductive/Graph/Properties.hs +18/−18
- test/Data/Graph/Inductive/Query/Properties.hs +53/−22
- test/TestSuite.hs +2/−2
ChangeLog view
@@ -1,3 +1,48 @@+5.8.3.1+-------++* Support QuickCheck 2.17.++* Removed HLint ANN pragmas.++5.8.3.0+-------++* Data.Graph.Inductive.NodeMap now has functions mkLookupNode,+ insMapLookupNode, memberNode, and lookupNode for detecting whether a+ graph already contains a node (issue #72, PR #77).++5.8.2.0+-------++* Data.Graph.Inductive.Graph now only requires Graph, not DynGraph+ (issue #100).++* Documented that some functions are partial (issue #98).++* Add `insert` function as synonym for `&` (issue #90).++5.8.1.1+-------++* Data.Graph.Inductive.Query.Dominators.{dom,iDom} could fail for some+ graphs (issue #109, regression in 5.8.1.0).++5.8.1.0+-------++* Data.Graph.Inductive.PatriciaTree.Gr and+ Data.Graph.Inductive.Tree.Gr now have Functor instances.++* 'Gr a' is now an instance of Functor.++5.8.0.0+-------++* Breaking change: MonadFail is no longer a superclass of GraphM.+ This is to support GHC 9.4. This has no effect on the IO and ST+ instances of GraphM, but may affect users.+ 5.7.0.3 -------
Data/Graph/Inductive/Graph.hs view
@@ -34,6 +34,7 @@ Graph(..), DynGraph(..), -- * Operations+ insert, order, size, -- ** Graph Folds and Maps@@ -156,9 +157,10 @@ matchAny :: gr a b -> GDecomp gr a b matchAny g = case labNodes g of [] -> error "Match Exception, Empty Graph"- (v,_):_ -> (c,g')- where- (Just c,g') = match v g+ (v,_):_ ->+ case match v g of+ (Just c,g') -> (c,g')+ _ -> error "Match Exception, cannot extract node" -- | The number of 'Node's in a 'Graph'. noNodes :: gr a b -> Int@@ -186,6 +188,10 @@ -- in the graph. (&) :: Context a b -> gr a b -> gr a b +-- | A synonym for '&', to avoid conflicts with the similarly named+-- operator in "Data.Function".+insert :: DynGraph gr => Context a b -> gr a b -> gr a b+insert = (&) -- | The number of nodes in the graph. An alias for 'noNodes'. order :: (Graph gr) => gr a b -> Int@@ -302,7 +308,7 @@ -- -- NOTE: in the case of multiple edges with the same label, this -- will only delete the /first/ such edge. To delete all such--- edges, please use 'delAllLedge'.+-- edges, please use 'delAllLEdge'. delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b delLEdge = delLEdgeBy delete @@ -577,7 +583,7 @@ -- | Pretty-print the graph. Note that this loses a lot of -- information, such as edge inverses, etc.-prettify :: (DynGraph gr, Show a, Show b) => gr a b -> String+prettify :: (Graph gr, Show a, Show b) => gr a b -> String prettify g = foldr (showsContext . context g) id (nodes g) "" where showsContext (_,n,l,s) sg = shows n . (':':) . shows l
Data/Graph/Inductive/Internal/RootPath.hs view
@@ -29,7 +29,7 @@ | otherwise = findP v ps getPath :: Node -> RTree -> Path-getPath v = reverse . first (\(w:_)->w==v)+getPath v = reverse . first ((==v) . head) getLPath :: Node -> LRTree a -> LPath a getLPath v = LP . reverse . findP v
Data/Graph/Inductive/Monad.hs view
@@ -19,13 +19,7 @@ import Data.Graph.Inductive.Graph-#if MIN_VERSION_base(4,12,0)-import Control.Monad.Fail-import Prelude hiding (fail)-#endif -{-# ANN module "HLint: ignore Redundant lambda" #-}- ---------------------------------------------------------------------- -- MONADIC GRAPH CLASS ----------------------------------------------------------------------@@ -43,13 +37,7 @@ -- Monadic Graph ---class-#if MIN_VERSION_base(4,12,0)- (MonadFail m)-#else- (Monad m)-#endif- => GraphM m gr where+class (Monad m) => GraphM m gr where {-# MINIMAL emptyM, isEmptyM, matchM, mkGraphM, labNodesM #-} emptyM :: m (gr a b)@@ -65,9 +53,11 @@ matchAnyM :: m (gr a b) -> m (GDecomp gr a b) matchAnyM g = do vs <- labNodesM g case vs of- [] -> fail "Match Exception, Empty Graph"- (v,_):_ -> do (Just c,g') <- matchM v g- return (c,g')+ [] -> error "Match Exception, Empty Graph"+ (v,_):_ -> do r <- matchM v g+ case r of+ (Just c,g') -> return (c,g')+ _ -> error "Match Exception, cannot extract node" noNodesM :: m (gr a b) -> m Int noNodesM = labNodesM >>. length@@ -75,7 +65,7 @@ nodeRangeM :: m (gr a b) -> m (Node,Node) nodeRangeM g = do isE <- isEmptyM g if isE- then fail "nodeRangeM of empty graph"+ then error "nodeRangeM of empty graph" else do vs <- nodesM g return (minimum vs,maximum vs)
Data/Graph/Inductive/NodeMap.hs view
@@ -6,13 +6,13 @@ -- * Functional Construction NodeMap, -- ** Map Construction- new, fromGraph, mkNode, mkNode_, mkNodes, mkNodes_, mkEdge, mkEdges,+ new, fromGraph, mkNode, mkNode_, mkNodes, mkLookupNode, mkNodes_, mkEdge, mkEdges, -- ** Graph Construction -- | These functions mirror the construction and destruction functions in -- 'Data.Graph.Inductive.Graph', but use the given 'NodeMap' to look up -- the appropriate 'Node's. Note that the 'insMapNode' family of functions -- will create new nodes as needed, but the other functions will not.- insMapNode, insMapNode_, insMapEdge, delMapNode, delMapEdge, insMapNodes,+ insMapNode, insMapLookupNode, insMapNode_, insMapEdge, delMapNode, delMapEdge, insMapNodes, insMapNodes_, insMapEdges, delMapNodes, delMapEdges, mkMapGraph, -- * Monadic Construction NodeMapM,@@ -23,7 +23,10 @@ run, run_, mkNodeM, mkNodesM, mkEdgeM, mkEdgesM, -- ** Graph Construction insMapNodeM, insMapEdgeM, delMapNodeM, delMapEdgeM, insMapNodesM,- insMapEdgesM, delMapNodesM, delMapEdgesM+ insMapEdgesM, delMapNodesM, delMapEdgesM,++ -- ** Map inspection+ memberNode, lookupNode ) where import Control.Monad.Trans.State@@ -62,15 +65,30 @@ (m, k) = foldr aux (M.empty, 0) ns in NodeMap { map = m, key = k+1 } +-- | Is the node in the map ?+memberNode :: (Ord a) => a -> NodeMap a -> Bool+memberNode a = M.member a . map++-- | Lookup for the node in the map.+lookupNode :: (Ord a) => a -> NodeMap a -> Maybe Node+lookupNode a = M.lookup a . map+ -- | Generate a labelled node from the given label. Will return the same node -- for the same label. mkNode :: (Ord a) => NodeMap a -> a -> (LNode a, NodeMap a)-mkNode m@(NodeMap mp k) a =+mkNode m = forgetFst . mkLookupNode m+ where+ forgetFst (_,x,y)=(x,y)++-- | Act as 'mkNode', but return also a boolean set as @True@ if the node was+-- already in the map.+mkLookupNode :: (Ord a) => NodeMap a -> a -> (Bool, LNode a, NodeMap a)+mkLookupNode m@(NodeMap mp k) a = case M.lookup a mp of- Just i -> ((i, a), m)- Nothing ->+ Just i -> (True,(i, a), m)+ Nothing -> let m' = NodeMap { map = M.insert a k mp, key = k+1 }- in ((k, a), m')+ in (False,(k, a), m') -- | Generate a labelled node and throw away the modified 'NodeMap'. mkNode_ :: (Ord a) => NodeMap a -> a -> LNode a@@ -107,25 +125,34 @@ let (n, m') = mkNode m a in (insNode n g, m', n) +-- | Act as 'insMapNode', but return also a boolean set as @True@ if the node was+-- already in the map.+insMapLookupNode :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> (Bool, g a b, NodeMap a, LNode a)+insMapLookupNode m a g =+ let (b, n, m') = mkLookupNode m a+ in (b, insNode n g, m', n)+ insMapNode_ :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> g a b insMapNode_ m a g = let (g', _, _) = insMapNode m a g in g' +-- | Partial function: raises exception if passed nodes that are not in the graph. insMapEdge :: (Ord a, DynGraph g) => NodeMap a -> (a, a, b) -> g a b -> g a b insMapEdge m e g =- let (Just e') = mkEdge m e- in insEdge e' g+ case mkEdge m e of Just e' -> insEdge e' g+ Nothing -> error "insMapEdge: invalid edge" delMapNode :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> g a b delMapNode m a g = let (n, _) = mkNode_ m a in delNode n g +-- | Partial function: raises exception if passed nodes that are not in the graph. delMapEdge :: (Ord a, DynGraph g) => NodeMap a -> (a, a) -> g a b -> g a b delMapEdge m (n1, n2) g =- let Just (n1', n2', _) = mkEdge m (n1, n2, ())- in delEdge (n1', n2') g+ case mkEdge m (n1, n2, ()) of Just (n1', n2', _) -> delEdge (n1', n2') g+ Nothing -> error "delMapEdge: invalid edge" insMapNodes :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> (g a b, NodeMap a, [LNode a]) insMapNodes m as g =@@ -137,27 +164,33 @@ let (g', _, _) = insMapNodes m as g in g' +-- | Partial function: raises exception if passed nodes that are not in the graph. insMapEdges :: (Ord a, DynGraph g) => NodeMap a -> [(a, a, b)] -> g a b -> g a b insMapEdges m es g =- let Just es' = mkEdges m es- in insEdges es' g+ case mkEdges m es of Just es' -> insEdges es' g+ Nothing -> error "insMapEdges: invalid edge" delMapNodes :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> g a b delMapNodes m as g = let ns = P.map fst $ mkNodes_ m as in delNodes ns g +-- | Partial function: raises exception if passed nodes that are not in the graph. delMapEdges :: (Ord a, DynGraph g) => NodeMap a -> [(a, a)] -> g a b -> g a b delMapEdges m ns g =- let Just ns' = mkEdges m $ P.map (\(a, b) -> (a, b, ())) ns- ns'' = P.map (\(a, b, _) -> (a, b)) ns'- in delEdges ns'' g+ case mkEdges m $ P.map (\(a, b) -> (a, b, ())) ns of+ Nothing -> error "delMapEdges: invalid edges"+ Just ns' ->+ let ns'' = P.map (\(a, b, _) -> (a, b)) ns'+ in delEdges ns'' g +-- | Partial function: raises exception if passed a node that is not in the graph. mkMapGraph :: (Ord a, DynGraph g) => [a] -> [(a, a, b)] -> (g a b, NodeMap a) mkMapGraph ns es = let (ns', m') = mkNodes new ns- Just es' = mkEdges m' es- in (mkGraph ns' es', m')+ in case mkEdges m' es of+ Just es' -> (mkGraph ns' es', m')+ Nothing -> error "mkMapGraph: invalid edges" -- | Graph construction monad; handles passing both the 'NodeMap' and the -- 'Graph'.
Data/Graph/Inductive/PatriciaTree.hs view
@@ -134,6 +134,9 @@ rnf (Gr g) = rnf g #endif +instance Functor (Gr a) where+ fmap = fastEMap+ #if MIN_VERSION_base (4,8,0) instance Bifunctor Gr where bimap = fastNEMap
Data/Graph/Inductive/Query/BCC.hs view
@@ -43,10 +43,11 @@ splitGraphs :: (DynGraph gr) => [gr a b] -> [Node] -> [gr a b] splitGraphs gs [] = gs splitGraphs [] _ = error "splitGraphs: empty graph list"-splitGraphs gs (v:vs) = splitGraphs (gs''++gs''') vs- where gs'' = embedContexts c gs'- gs' = gComponents g'- ((Just c,g'), gs''') = findGraph v gs+splitGraphs gs (v:vs) = case findGraph v gs of+ ((Nothing, _), _) -> error "splitGraphs: invalid node"+ ((Just c,g'), gs''') -> splitGraphs (gs''++gs''') vs+ where gs'' = embedContexts c gs'+ gs' = gComponents g' {-| Finds the bi-connected components of an undirected connected graph.
Data/Graph/Inductive/Query/BFS.hs view
@@ -107,10 +107,12 @@ bf :: (Graph gr) => Queue Path -> gr a b -> RTree bf q g | queueEmpty q || isEmpty g = [] | otherwise =- case match v g of- (Just c, g') -> p:bf (queuePutList (map (:p) (suc' c)) q') g'- (Nothing, g') -> bf q' g'- where (p@(v:_),q') = queueGet q+ case queueGet q of+ ([], _) -> []+ (p@(v:_),q') ->+ case match v g of+ (Just c, g') -> p:bf (queuePutList (map (:p) (suc' c)) q') g'+ (Nothing, g') -> bf q' g' esp :: (Graph gr) => Node -> Node -> gr a b -> Path esp s t = getPath t . bft s@@ -128,11 +130,13 @@ lbf :: (Graph gr) => Queue (LPath b) -> gr a b -> LRTree b lbf q g | queueEmpty q || isEmpty g = [] | otherwise =- case match v g of- (Just c, g') ->- LP p:lbf (queuePutList (map (\v' -> LP (v':p)) (lsuc' c)) q') g'- (Nothing, g') -> lbf q' g'- where (LP (p@((v,_):_)),q') = queueGet q+ case queueGet q of+ (LP [], _) -> []+ (LP (p@((v,_):_)),q') ->+ case match v g of+ (Just c, g') ->+ LP p:lbf (queuePutList (map (\v' -> LP (v':p)) (lsuc' c)) q') g'+ (Nothing, g') -> lbf q' g' lesp :: (Graph gr) => Node -> Node -> gr a b -> LPath b lesp s t = getLPath t . lbft s
Data/Graph/Inductive/Query/Dominators.hs view
@@ -17,16 +17,16 @@ import Data.Graph.Inductive.Query.DFS import Data.IntMap (IntMap) import qualified Data.IntMap as I+import Data.Maybe (mapMaybe) import Data.Tree (Tree (..)) import qualified Data.Tree as T -{-# ANN iDom "HLint: ignore Use ***" #-}--- | return immediate dominators for each node of a graph, given a root+-- | return immediate dominators for each reachable node of a graph, given a root iDom :: (Graph gr) => gr a b -> Node -> [(Node,Node)] iDom g root = let (result, toNode, _) = idomWork g root in map (\(a, b) -> (toNode ! a, toNode ! b)) (assocs result) --- | return the set of dominators of the nodes of a graph, given a root+-- | return the set of dominators of the reachable nodes of a graph, given a root dom :: (Graph gr) => gr a b -> Node -> [(Node,[Node])] dom g root = let (iD, toNode, fromNode) = idomWork g root@@ -50,24 +50,26 @@ type FromNode = IntMap Node' idomWork :: (Graph gr) => gr a b -> Node -> (IDom, ToNode, FromNode)-idomWork g root = let- -- use depth first tree from root do build the first approximation- trees@(~[tree]) = dff [root] g- -- relabel the tree so that paths from the root have increasing nodes- (s, ntree) = numberTree 0 tree- -- the approximation iDom0 just maps each node to its parent- iD0 = array (1, s-1) (tail $ treeEdges (-1) ntree)- -- fromNode translates graph nodes to relabeled (internal) nodes- fromNode = I.unionWith const (I.fromList (zip (T.flatten tree) (T.flatten ntree))) (I.fromList (zip (nodes g) (repeat (-1))))- -- toNode translates internal nodes to graph nodes- toNode = array (0, s-1) (zip (T.flatten ntree) (T.flatten tree))- preds = array (1, s-1) [(i, filter (/= -1) (map (fromNode I.!)- (pre g (toNode ! i)))) | i <- [1..s-1]]- -- iteratively improve the approximation to find iDom.- iD = fixEq (refineIDom preds) iD0- in- if null trees then error "Dominators.idomWork: root not in graph"- else (iD, toNode, fromNode)+idomWork g root =+ case dff [root] g of+ [] -> error "Dominators.idomWork: root not in graph"+ tree : _ ->+ let+ nds = reachable root g+ -- use depth first tree from root do build the first approximation+ -- relabel the tree so that paths from the root have increasing nodes+ (s, ntree) = numberTree 0 tree+ -- the approximation iDom0 just maps each node to its parent+ iD0 = array (1, s-1) (tail $ treeEdges (-1) ntree)+ -- fromNode translates graph nodes to relabeled (internal) nodes+ fromNode = I.unionWith const (I.fromList (zip (T.flatten tree) (T.flatten ntree))) (I.fromList (zip nds (repeat (-1))))+ -- toNode translates internal nodes to graph nodes+ toNode = array (0, s-1) (zip (T.flatten ntree) (T.flatten tree))+ preds = array (1, s-1) [(i, filter (/= -1) (mapMaybe (`I.lookup` fromNode)+ (pre g (toNode ! i)))) | i <- [1..s-1]]+ -- iteratively improve the approximation to find iDom.+ iD = fixEq (refineIDom preds) iD0+ in (iD, toNode, fromNode) -- for each node in iDom, find the intersection of all its predecessor's -- dominating sets, and update iDom accordingly.
Data/Graph/Inductive/Query/Indep.hs view
@@ -22,12 +22,14 @@ indepSize :: (DynGraph gr) => gr a b -> ([Node], Int) indepSize g | isEmpty g = ([], 0)- | l1 > l2 = il1- | otherwise = il2+ | otherwise =+ case match v g of+ (Nothing,_) -> error "indepSize: unexpected invalid node"+ (Just c,g') ->+ let il1@(_,l1) = indepSize g'+ il2@(_,l2) = ((v:) *** (+1)) $ indepSize (delNodes (neighbors' c) g')+ in if l1 > l2 then il1 else il2 where vs = nodes g v = snd . maximumBy (compare `on` fst) . map ((,) =<< deg g) $ vs- (Just c,g') = match v g- il1@(_,l1) = indepSize g'- il2@(_,l2) = ((v:) *** (+1)) $ indepSize (delNodes (neighbors' c) g')
Data/Graph/Inductive/Query/MST.hs view
@@ -20,10 +20,12 @@ prim :: (Graph gr,Real b) => H.Heap b (LPath b) -> gr a b -> LRTree b prim h g | H.isEmpty h || isEmpty g = [] prim h g =- case match v g of- (Just c,g') -> p:prim (H.mergeAll (h':newEdges p c)) g'- (Nothing,g') -> prim h' g'- where (_,p@(LP ((v,_):_)),h') = H.splitMin h+ case H.splitMin h of+ (_,p@(LP ((v,_):_)),h') ->+ case match v g of+ (Just c,g') -> p:prim (H.mergeAll (h':newEdges p c)) g'+ (Nothing,g') -> prim h' g'+ _ -> [] msTreeAt :: (Graph gr,Real b) => Node -> gr a b -> LRTree b msTreeAt v = prim (H.unit 0 (LP [(v,0)]))
Data/Graph/Inductive/Query/MaxFlow.hs view
@@ -64,10 +64,11 @@ -- residual capacity of that edge's label. Then return the updated -- list. updAdjList::(Num b) => Adj (b,b,b) -> Node -> b -> Bool -> Adj (b,b,b)-updAdjList s v cf fwd = rs ++ ((x,y+cf',z-cf'),w) : rs'+updAdjList s v cf fwd =+ case break ((v==) . snd) s of+ (rs, ((x,y,z),w):rs') -> rs ++ ((x,y+cf',z-cf'),w) : rs'+ _ -> error "updAdjList: invalid node" where- (rs, ((x,y,z),w):rs') = break ((v==) . snd) s- cf' = if fwd then cf else negate cf
Data/Graph/Inductive/Query/MaxFlow2.hs view
@@ -77,7 +77,7 @@ -- Compute an augmenting path augPathFused :: Network -> Node -> Node -> Maybe DirPath augPathFused g s t = listToMaybe $ map reverse $- filter (\((u,_):_) -> u==t) tree+ filter ((==t) . fst . head) tree where tree = bftForEK s g -- Breadth First Search wrapper function@@ -87,8 +87,12 @@ -- Breadth First Search, tailored for Edmonds & Karp bfForEK :: Queue DirPath -> Network -> DirRTree bfForEK q g- | queueEmpty q || isEmpty g = []- | otherwise = case match v g of+ | queueEmpty q || isEmpty g = []+ | otherwise =+ case queueGet q of+ ([], _) -> []+ (p@((v,_):_), q1) ->+ case match v g of (Nothing, g') -> bfForEK q1 g' (Just (preAdj, _, _, sucAdj), g') -> p:bfForEK q2 g' where@@ -100,7 +104,6 @@ -- Traverse edges forwards if flow less than capacity suc2 = [ (sucNode,Forward):p | ((c, f), sucNode) <- sucAdj, c>f]- where (p@((v,_):_), q1)=queueGet q -- Extract augmenting path from network; return path as a sequence of -- edges with direction of traversal, and new network with augmenting@@ -110,13 +113,17 @@ extractPathFused g [] = ([], g) extractPathFused g [(_,_)] = ([], g) extractPathFused g ((u,_):rest@((v,Forward):_)) =- ((u, v, l, Forward):tailedges, newerg)- where (tailedges, newerg) = extractPathFused newg rest- Just (l, newg) = extractEdge g u v (uncurry (>))+ case extractEdge g u v (uncurry (>)) of+ Just (l, newg) ->+ let (tailedges, newerg) = extractPathFused newg rest+ in ((u, v, l, Forward):tailedges, newerg)+ Nothing -> error "extractPathFused Forward: invalid edge" extractPathFused g ((u,_):rest@((v,Backward):_)) =- ((v, u, l, Backward):tailedges, newerg)- where (tailedges, newerg) = extractPathFused newg rest- Just (l, newg) = extractEdge g v u (\(_,f)->(f>0))+ case extractEdge g v u (\(_,f)->(f>0)) of+ Just (l, newg) ->+ let (tailedges, newerg) = extractPathFused newg rest+ in ((v, u, l, Backward):tailedges, newerg)+ Nothing -> error "extractPathFused Backward: invalid edge" ekFusedStep :: EKStepFunc ekFusedStep g s t = case maybePath of@@ -142,7 +149,7 @@ [(v, u, f) | (u,v,(_,f)) <- labEdges g, f>0]) augPath :: Network -> Node -> Node -> Maybe Path-augPath g s t = listToMaybe $ map reverse $ filter (\(u:_) -> u==t) tree+augPath g s t = listToMaybe $ map reverse $ filter ((==t) . head) tree where tree = bft s (residualGraph g) -- Extract augmenting path from network; return path as a sequence of@@ -168,12 +175,12 @@ -- Return the label on the edge and the graph without the edge extractEdge :: Gr a b -> Node -> Node -> (b->Bool) -> Maybe (b, Gr a b) extractEdge g u v p =- case adj of- Just (el, _) -> Just (el, (p', node, l, rest) & newg)- Nothing -> Nothing- where (Just (p', node, l, s), newg) = match u g- (adj, rest)=extractAdj s- (\(l', dest) -> dest==v && p l')+ case match u g of+ ((Just (p', node, l, s), newg)) ->+ let (adj, rest)=extractAdj s (\(l', dest) -> dest==v && p l')+ in do (el, _) <- adj+ Just (el, (p', node, l, rest) & newg)+ _ -> Nothing -- Extract an item from an adjacency list that satisfies a given -- predicate. Return the item and the rest of the adjacency list
Data/Graph/Inductive/Query/Monad.hs view
@@ -78,11 +78,11 @@ fmap = liftM instance (Monad m) => Applicative (GT m g) where- pure = return+ pure x = MGT (\mg->do {g<-mg; return (x,g)}) (<*>) = ap instance (Monad m) => Monad (GT m g) where- return x = MGT (\mg->do {g<-mg; return (x,g)})+ return = pure f >>= h = MGT (\mg->do {(x,g)<-apply f mg; apply' (h x) g}) condMGT' :: (Monad m) => (s -> Bool) -> GT m s a -> GT m s a -> GT m s a@@ -218,14 +218,15 @@ dffM vs = MGT (\mg-> do g<-mg b<-isEmptyM mg- if b||null vs then return ([],g) else- let (v:vs') = vs in- do (mc,g1) <- matchM v mg+ case (b, vs) of+ (False, v:vs') -> do+ (mc,g1) <- matchM v mg case mc of Nothing -> apply (dffM vs') (return g1) Just c -> do (ts, g2) <- apply (dffM (suc' c)) (return g1) (ts',g3) <- apply (dffM vs') (return g2) return (Node (node' c) ts:ts',g3)+ _ -> return ([],g) ) graphDff :: (GraphM m gr) => [Node] -> m (gr a b) -> m [Tree Node]
Data/Graph/Inductive/Query/SP.hs view
@@ -28,10 +28,12 @@ -> LRTree b dijkstra h g | H.isEmpty h || isEmpty g = [] dijkstra h g =- case match v g of- (Just c,g') -> p:dijkstra (H.mergeAll (h':expand d p c)) g'- (Nothing,g') -> dijkstra h' g'- where (_,p@(LP ((v,d):_)),h') = H.splitMin h+ case H.splitMin h of+ (_,p@(LP ((v,d):_)),h') ->+ case match v g of+ (Just c,g') -> p:dijkstra (H.mergeAll (h':expand d p c)) g'+ (Nothing,g') -> dijkstra h' g'+ _ -> [] -- | Tree of shortest paths from a certain node to the rest of the -- (reachable) nodes.
Data/Graph/Inductive/Query/TransClos.hs view
@@ -18,8 +18,8 @@ outU gr = map toEdge . out gr {-|-Finds the transitive, reflexive closure of a directed graph.-Given a graph G=(V,E), its transitive closure is the graph:+Finds the reflexive-transitive closure of a directed graph.+Given a graph G=(V,E), its reflexive-transitive closure is the graph: G* = (V,E*) where E*={(i,j): i,j in V and either i = j or there is a path from i to j in G} -} trc :: (DynGraph gr) => gr a b -> gr a ()@@ -30,11 +30,12 @@ {-| Finds the reflexive closure of a directed graph.-Given a graph G=(V,E), its transitive closure is the graph:+Given a graph G=(V,E), its reflexive closure is the graph: G* = (V,Er union E) where Er = {(i,i): i in V} -} rc :: (DynGraph gr) => gr a b -> gr a ()-rc g = newEdges `insEdges` insNodes ln empty+rc g = (newEdges ++ oldEdges) `insEdges` insNodes ln empty where ln = labNodes g newEdges = [ (u, u, ()) | (u, _) <- ln ]+ oldEdges = [ (u, v, ()) | (u, v, _) <- labEdges g ]
Data/Graph/Inductive/Tree.hs view
@@ -135,6 +135,9 @@ rnf (Gr g) = rnf g #endif +instance Functor (Gr a) where+ fmap = emap+ #if MIN_VERSION_base (4,8,0) instance Bifunctor Gr where bimap = nemap
LICENSE view
@@ -1,5 +1,6 @@ Copyright (c) 1999-2008, Martin Erwig 2010, Ivan Lazar Miljenovic+ 2023, Troels Henriksen All rights reserved. Redistribution and use in source and binary forms, with or without
fgl-arbitrary/Data/Graph/Inductive/Arbitrary.hs view
@@ -321,23 +321,24 @@ toConnGraph :: forall ag a b. (ArbGraph ag, Arbitrary a, Arbitrary b) => ag a b -> Gen (Connected ag a b)-toConnGraph ag = do a <- arbitrary- ces <- concat <$> mapM mkE ws- return $ CG { connNode = v- , connArbGraph = fromBaseGraph- . insEdges ces- . insNode (v,a)- $ g- }+toConnGraph ag = case newNodes 1 g of+ [] -> error "toConnGraph: cannot make node"+ v:_ -> do+ a <- arbitrary+ ces <- concat <$> mapM (mkE v) ws+ return $ CG { connNode = v+ , connArbGraph = fromBaseGraph+ . insEdges ces+ . insNode (v,a)+ $ g+ } where g = toBaseGraph ag - [v] = newNodes 1 g- ws = nodes g - mkE w = do b <- arbitrary- return (edgeF p [(v,w,b)])+ mkE v w = do b <- arbitrary+ return (edgeF p [(v,w,b)]) p :: GrProxy ag p = GrProxy
fgl.cabal view
@@ -1,36 +1,35 @@ name: fgl-version: 5.7.0.3+version: 5.8.3.1 license: BSD3 license-file: LICENSE author: Martin Erwig, Ivan Lazar Miljenovic-maintainer: Ivan.Miljenovic@gmail.com+maintainer: athas@sigkill.dk category: Data Structures, Graphs synopsis: Martin Erwig's Functional Graph Library -description: {-An inductive representation of manipulating graph data structures.-.-Original website can be found at <http://web.engr.oregonstate.edu/~erwig/fgl/haskell>.-}+description:+ An inductive representation of manipulating graph data structures.+ .+ Original website can be found at <http://web.engr.oregonstate.edu/~erwig/fgl/haskell>. cabal-version: >= 1.10 build-type: Simple extra-source-files: ChangeLog -tested-with: GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4,- GHC == 7.10.2, GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.3,- GHC == 8.6.2, GHC == 8.8.2, GHC == 8.10.1+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4,+ GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2,+ GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4,+ GHC == 9.10.3, GHC == 9.12.2 source-repository head type: git location: https://github.com/haskell/fgl.git -flag containers042 {+flag containers042 manual: False default: True-} -library {+library default-language: Haskell98 exposed-modules:@@ -72,7 +71,7 @@ if flag(containers042) build-depends: containers >= 0.4.2- , deepseq >= 1.1.0.0 && < 1.5+ , deepseq >= 1.1.0.0 && < 1.6 else build-depends: containers < 0.4.2 @@ -82,17 +81,15 @@ ghc-options: -Wall -}--test-suite fgl-tests {+test-suite fgl-tests default-language: Haskell98 type: exitcode-stdio-1.0 build-depends: fgl , base- , QuickCheck >= 2.8 && < 2.15- , hspec >= 2.1 && < 2.8+ , QuickCheck >= 2.8 && < 2.17+ , hspec >= 2.1 && < 2.12 , containers hs-source-dirs: test@@ -106,10 +103,10 @@ , Data.Graph.Inductive.Query.Properties ghc-options: -Wall--}+ if impl(ghc >= 8.0)+ ghc-options: -Wall -Wno-star-is-type -benchmark fgl-benchmark {+benchmark fgl-benchmark if flag(containers042) buildable: True else@@ -131,5 +128,3 @@ , deepseq ghc-options: -Wall--}
test/Data/Graph/Inductive/Graph/Properties.hs view
@@ -194,18 +194,17 @@ -- current behaviour is to throw an error if an existing node is -- used. valid_insNode :: (DynGraph gr, Ord a, Ord b) => gr a b -> a -> Bool-valid_insNode g l = gelem v g'- && sort (labNodes g') == sort (vl : labNodes g)- && sort (labEdges g') == sort (labEdges g)- -- Note: not testing whether this changes- -- nodeRange because newNodes /might/ return- -- unused nodes in the middle.- where- [v] = newNodes 1 g-- vl = (v,l)-- g' = insNode vl g+valid_insNode g l =+ case newNodes 1 g of+ [v] -> let vl = (v,l)+ g' = insNode vl g+ in gelem v g'+ && sort (labNodes g') == sort (vl : labNodes g)+ && sort (labEdges g') == sort (labEdges g)+ -- Note: not testing whether this changes+ -- nodeRange because newNodes /might/ return+ -- unused nodes in the middle.+ _ -> False -- | Insert a node for every label in the list, but don't add any new -- edges.@@ -329,12 +328,13 @@ -- adding the specified number to the graph and then deleting them. valid_delAllLEdge :: (DynGraph gr, Eq a, Eq b) => gr a b -> NonNegative Int -> a -> a -> b -> Bool-valid_delAllLEdge g (NonNegative c) a1 a2 b = equal g' (delAllLEdge le g'')- where- [v,w] = newNodes 2 g- g' = insNodes [(v,a1),(w,a2)] g- le = (v,w,b)- g'' = insEdges (replicate c le) g'+valid_delAllLEdge g (NonNegative c) a1 a2 b =+ case newNodes 2 g of+ [v,w] -> let g' = insNodes [(v,a1),(w,a2)] g+ le = (v,w,b)+ g'' = insEdges (replicate c le) g'+ in equal g' (delAllLEdge le g'')+ _ -> False -- | There is a version of 'mkGraph' in its documentation that uses -- 'DynGraph' (hence why it isn't used by default). This ensures
test/Data/Graph/Inductive/Query/Properties.hs view
@@ -133,14 +133,25 @@ -- Dominators test_dom :: Spec-test_dom = it "dom" $- sortIt (dom domGraph 1) `shouldMatchList` [ (1, [1])- , (2, [1,2])- , (3, [1,2,3])- , (4, [1,2,4])- , (5, [1,2,5])- , (6, [1,2,6])- ]+test_dom = describe "dom" $ do+ it "regular dom" $+ sortIt (dom domGraph 1) `shouldMatchList` [ (1, [1])+ , (2, [1,2])+ , (3, [1,2,3])+ , (4, [1,2,4])+ , (5, [1,2,5])+ , (6, [1,2,6])+ ]+ it "multiple components dom" $+ sortIt (dom domGraph1 1) `shouldMatchList` [ (1, [1])+ , (2, [1, 2])+ ]+ it "directed reachable components dom" $+ sortIt (dom domGraph2 1) `shouldMatchList` [ (1, [1]) ]++ it "unreachable nodes dom" $+ sortIt (dom domGraph3 1) `shouldMatchList` [(1,[1]), (2,[1,2])]+ where sortIt = map (second sort) @@ -160,6 +171,23 @@ , (5,2) ] +-- This graph has two components (independent subgraphs)+domGraph1 :: Gr () ()+domGraph1 = mkUGraph [1..3]+ [ (1,2)+ ]++-- This graph has no reachables from 1 (but 1 is reachable)+domGraph2 :: Gr () ()+domGraph2 = mkUGraph [1..3]+ [ (2,1)+ , (2,2)+ ]++-- From #109: 1 -> 2 <- 3+domGraph3 :: Gr () ()+domGraph3 = mkUGraph [1..3] [(1,2), (3,2)]+ -- ----------------------------------------------------------------------------- -- GVD @@ -333,26 +361,29 @@ test_sp_Just :: (ArbGraph gr, Graph gr, Real b) => Proxy (gr a b) -> gr a b -> Property test_sp_Just _ g =- (noNodes g >= 2 && v `elem` bfs u g) ==>- isJust (spLength u v g) &&- isJust maybePath &&- not (null path) &&- head path == u &&- last path == v- where- [u,v] = take 2 (nodes g)- maybePath@(Just path) = sp u v g+ case nodes g of+ u:v:_ ->+ v `elem` bfs u g ==>+ isJust (spLength u v g) &&+ case sp u v g of+ Nothing -> False+ Just path ->+ not (null path) &&+ head path == u &&+ last path == v+ _ -> property True -- | Test that 'spLength' and 'sp' return 'Nothing' when destination -- is not reachable from source. test_sp_Nothing :: (ArbGraph gr, Graph gr, Real b) => Proxy (gr a b) -> gr a b -> Property test_sp_Nothing _ g =- (noNodes g >= 2 && not (v `elem` bfs u g)) ==>- isNothing (spLength u v g) &&- isNothing (sp u v g)- where- [u,v] = take 2 (nodes g)+ case nodes g of+ u:v:_ ->+ not (v `elem` bfs u g) ==>+ isNothing (spLength u v g) &&+ isNothing (sp u v g)+ _ -> property True -- ----------------------------------------------------------------------------- -- TransClos
test/TestSuite.hs view
@@ -79,7 +79,7 @@ propType "subgraph" valid_subgraph where- proxyProp str = prop str . ($p)+ proxyProp str = prop str . ($ p) propType :: (Testable pr) => String -> (GraphType gr -> pr) -> Spec propType = prop@@ -126,7 +126,7 @@ propP "tc" test_tc propP "rc" test_rc where- propP str = prop str . ($p)+ propP str = prop str . ($ p) p :: PatriciaTreeP p = Proxy