fgl 5.5.1.0 → 5.5.2.0

raw patch · 33 files changed

+2531/−767 lines, 33 filesdep +QuickCheckdep +deepseqdep +fgldep −mtldep ~basedep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, deepseq, fgl, ghc-prim, hspec, transformers

Dependencies removed: mtl

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• ChangeLog +206/−0
• Data/Graph/Inductive.hs +11/−17
• Data/Graph/Inductive/Basic.hs +20/−13
• Data/Graph/Inductive/Example.hs +5/−5
• Data/Graph/Inductive/Graph.hs +267/−178
• Data/Graph/Inductive/Internal/Heap.hs +31/−21
• Data/Graph/Inductive/Internal/Queue.hs +3/−3
• Data/Graph/Inductive/Internal/RootPath.hs +4/−16
• Data/Graph/Inductive/Internal/Thread.hs +4/−4
• Data/Graph/Inductive/Monad.hs +57/−40
• Data/Graph/Inductive/NodeMap.hs +12/−8
• Data/Graph/Inductive/PatriciaTree.hs +79/−62
• Data/Graph/Inductive/Query.hs +14/−28
• Data/Graph/Inductive/Query/ArtPoint.hs +7/−7
• Data/Graph/Inductive/Query/BCC.hs +11/−11
• Data/Graph/Inductive/Query/BFS.hs +33/−25
• Data/Graph/Inductive/Query/DFS.hs +157/−142
• Data/Graph/Inductive/Query/Dominators.hs +17/−16
• Data/Graph/Inductive/Query/GVD.hs +33/−12
• Data/Graph/Inductive/Query/Indep.hs +24/−14
• Data/Graph/Inductive/Query/MST.hs +7/−5
• Data/Graph/Inductive/Query/MaxFlow.hs +71/−59
• Data/Graph/Inductive/Query/MaxFlow2.hs +18/−17
• Data/Graph/Inductive/Query/Monad.hs +41/−41
• Data/Graph/Inductive/Query/SP.hs +34/−8
• Data/Graph/Inductive/Query/TransClos.hs +5/−4
• Data/Graph/Inductive/Tree.hs +30/−8
• fgl-arbitrary/Data/Graph/Inductive/Arbitrary.hs +358/−0
• fgl.cabal +42/−3
• test/Data/Graph/Inductive/Graph/Properties.hs +410/−0
• test/Data/Graph/Inductive/Proxy.hs +45/−0
• test/Data/Graph/Inductive/Query/Properties.hs +346/−0
• test/TestSuite.hs +129/−0

@@ -1,3 +1,60 @@+5.5.2.0+-------++* Documentation, clean-up and refactoring of various parts of the+  library.++    - As part of this, various types now have instances for classes+      like `Show`, `Eq`, `Ord`, `NFData`, etc. where applicable.++    - In particular, the various options for use with depth-first+      search and shortest path queries was documented by David+      Luposchainsky.++* Addition of a proper test-suite.  So far it covers the+  `Data.Graph.Inductive.Graph` module and all+  `Data.Graph.Inductive.Query.*` modules except for `Monad`.++    - The tests are also automatically run for every (set of) commits+      thanks to Travis-CI.++* Arbitrary instances for the two graph types are now available in the+  new `fgl-arbitrary` sub-package.++* Now depends solely on the `transformers` library rather than `mtl`.++* Potentially breaking changes:++    These changes are those where the behaviour was un-specified or+    didn't match the documentation.++    - `nodeRange` and `nodeRangeM` for the various graph data+      structures erroneously returned `(0,0)` for empty graphs (making+      them indistinguishable from graphs containing the single node+      `0`).  They now match the default implementation of throwing an+      error.++    - The behaviour of `delLEdge` when dealing with multiple edges was+      unspecified; it now deletes only a single edge and the new+      function `delAllLEdge` deletes all edges matching the one+      provided.++* Additional functions thanks to Sergiu Ivanov:++    - Creating sub-graphs by `Node`- and `Context`-filtering as well+      as induced by a set of `Node`s.++    - Graph condensation (i.e. graph of+      strongly-connected-components).++    - Various edge- and neighbor-based helper functions.++* The graph types now have `Generic` instances thanks to Piotr+  Mlodawski.++* The `OrdGr` wrapper by Trevor Cook allows performing `Ord`-based+  comparisons on graphs.+ 5.5.1.0 ------- @@ -54,3 +111,152 @@  * Allow Data.Graph.Inductive.PatriciaTree to deal with multiple edges   between nodes.++5.4.2.2 (November 2008)+-----------------------++* Bugfix in Graphviz.sq++5.4.2.1 (June 2008)+-------------------++* bug fix in bcc by Reid Barton++* added new dynamic graph implementation:+  Data.Graph.Inductive.PatriciaTree (thanks to Pho)++* added test/benchmark.hs: a benchmark to compare Tree and PatriciaTree+  implementations (thanks to Pho)++5.4.2 (May 2008)+----------------++* added Setup.hs to tar file++* reimplementation of Data.Graph.Inductive.Query.Dominators+  by Bertram Felgenhauer:++  It was buggy and very slow for large graphs. See+      http://www.haskell.org/pipermail/haskell-cafe/2008-April/041739.html++  This patch also adds a new function, iDom, that returns the+  immediate dominators of the graph nodes.++* Exported xdf*With functions from DFS.hs++* many little cleanups thanks to many people+  (use 'darcs changes' to see the details)++5.4 (April 2007)+----------------++* changed the implementation for inspection functions (suc, pred, ...)+  to correct the behavior in the presence of loops (thanks to Ralf+  Juengling for pointing out the inconsistency)++5.3 (June 2006)+---------------++* fixed a bug in findP (thanks to lnagy@fit.edu)++* added function delLEdge in Graph.hs (thanks to Jose Labra)++* changed implementation of updFM and mkGraph (thanks to Don Stewart)++February 2005+-------------++* fixed an import error in Basic.hs++* removed Eq instance of gr because it caused overlapping instance+  problems.  Instead the function equal defined in Graph.hs can be+  used++* added some more functions to the export list of DFS.hs++* changed the definition of LPath into a newtype to avoid overlapping+  instances with lists++* fixed the Makefile (for GHC and GHCi)+++January 2004+------------++* bug fix for nearestNode (src/Data/Graph/Inductive/Query/GVD.hs)+  Update contributed by Aetion Technologies LLC (www.aetion.com)++* Refactor into hierarchical namespace++* Build changes:+  - build a standard haskell library (libHSfgl.a, HSfgl.o)+  - install as ghc package (fgl), uses Auto so no -package is needed++* Automatic Node generation for labels: Data.Graph.Inductive.NodeMap++* Graphviz output: Data.Graph.Inductive.Graphviz++September 2002+--------------++* Introduction of graph classes++* Monadic graphs and graph computation monad++* Graph implementation based on balanced (AVL) trees++* Fast graph implementation based on IO arrays++* New algorithms:+  - Maximum flow+  - Articulation points+  - biconnected components+  - dominators+  - transitive closure++* minor changes in utility functions+  - changed signatures (swapped order of arguments) of+    functions context and lab to be consistent with other graph functions+  - changed function first in RootPath: not existing path is now reported+    as an empty list and will not produce an error+  - esp version that returns a list of labeled edges+    (to find minimum label in maxflow algorithm)+  - BFS uses amortized O(1) queue+  - Heap stores key and value separately+  - ...++March 2001+----------+* Changes to User Guide++* a couple of new functions++* some internal changes++April 2000+----------++* User Guide++* Systematic structure for all depth-first search functions++* Graph Voronoi diagram++* Several small changes and additions in utility functions++February 2000+-------------++* Representation for inward-directed trees++* Breadth-first search++* Dijkstra's algorithm++* Minimum-spanning-tree algorithm+++August 1999+-----------++* First Haskell version

@@ -6,25 +6,19 @@ -- ------------------------------------------------------------------------------ -module Data.Graph.Inductive(-    module Data.Graph.Inductive.Graph,-    module Data.Graph.Inductive.PatriciaTree,-    module Data.Graph.Inductive.Basic,-    module Data.Graph.Inductive.Monad,-    module Data.Graph.Inductive.Monad.IOArray,-    module Data.Graph.Inductive.Query,-    module Data.Graph.Inductive.NodeMap,+module Data.Graph.Inductive+  ( module I     -- * Version Information-    version-) where+  , version+  ) where -import Data.Graph.Inductive.Basic-import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Monad-import Data.Graph.Inductive.Monad.IOArray-import Data.Graph.Inductive.NodeMap-import Data.Graph.Inductive.PatriciaTree-import Data.Graph.Inductive.Query+import Data.Graph.Inductive.Basic         as I+import Data.Graph.Inductive.Graph         as I+import Data.Graph.Inductive.Monad         as I+import Data.Graph.Inductive.Monad.IOArray as I+import Data.Graph.Inductive.NodeMap       as I+import Data.Graph.Inductive.PatriciaTree  as I+import Data.Graph.Inductive.Query         as I  import           Data.Version (showVersion) import qualified Paths_fgl    as Paths (version)

@@ -17,13 +17,14 @@   import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Internal.Thread (threadList, threadMaybe)+import Data.Graph.Inductive.Internal.Thread (Collect, Split, SplitM, threadList,+                                             threadMaybe)  import Data.List (nub) import Data.Tree  -- | Reverse the direction of all edges.-grev :: DynGraph gr => gr a b -> gr a b+grev :: (DynGraph gr) => gr a b -> gr a b grev = gmap (\(p,v,l,s)->(s,v,l,p))  -- | Make the graph undirected, i.e. for every edge from A to B, there@@ -36,14 +37,14 @@ --           let ps = nubBy (\x y->snd x==snd y) (p++s) in (ps,v,l,ps))  -- | Remove all labels.-unlab :: DynGraph gr => gr a b -> gr () ()+unlab :: (DynGraph gr) => gr a b -> gr () () unlab = gmap (\(p,v,_,s)->(unlabAdj p,v,(),unlabAdj s))         where unlabAdj = map (\(_,v)->((),v)) -- alternative: --    unlab = nmap (\_->()) . emap (\_->())  -- | Return all 'Context's for which the given function returns 'True'.-gsel :: Graph gr => (Context a b -> Bool) -> gr a b -> [Context a b]+gsel :: (Graph gr) => (Context a b -> Bool) -> gr a b -> [Context a b] gsel p = ufold (\c cs->if p c then c:cs else cs) []  @@ -54,14 +55,14 @@ --  -- | Filter based on edge property.-efilter :: DynGraph gr => (LEdge b -> Bool) -> gr a b -> gr a b+efilter :: (DynGraph gr) => (LEdge b -> Bool) -> gr a b -> gr a b efilter f = ufold cfilter empty             where cfilter (p,v,l,s) g = (p',v,l,s') & g                    where p' = filter (\(b,u)->f (u,v,b)) p                          s' = filter (\(b,w)->f (v,w,b)) s  -- | Filter based on edge label property.-elfilter :: DynGraph gr => (b -> Bool) -> gr a b -> gr a b+elfilter :: (DynGraph gr) => (b -> Bool) -> gr a b -> gr a b elfilter f = efilter (\(_,_,b)->f b)  @@ -69,18 +70,24 @@ --  -- | 'True' if the graph has any edges of the form (A, A).-hasLoop :: Graph gr => gr a b -> Bool-hasLoop = not . null . (gsel (\c->(node' c `elem` suc' c)))+hasLoop :: (Graph gr) => gr a b -> Bool+hasLoop = not . null . gsel (\c->node' c `elem` suc' c)  -- | The inverse of 'hasLoop'.-isSimple :: Graph gr => gr a b -> Bool+isSimple :: (Graph gr) => gr a b -> Bool isSimple = not . hasLoop -+threadGraph :: (Graph gr) => (Context a b -> r -> t)+               -> Split (gr a b) (Context a b) r -> SplitM (gr a b) Node t threadGraph f c = threadMaybe f c match  -- gfold1 f d b u = threadGraph (\c->d (labNode' c)) (\c->gfoldn f d b u (f c))-gfold1 f d b = threadGraph d (\c->gfoldn f d b (f c))+gfold1 :: (Graph gr) => (Context a b -> [Node]) -> (Context a b -> r -> t)+          -> Collect (Maybe t) r -> SplitM (gr a b) Node t+gfold1 f d b = threadGraph d (gfoldn f d b . f)++gfoldn :: (Graph gr) => (Context a b -> [Node]) -> (Context a b -> r -> t)+          -> Collect (Maybe t) r -> [Node] -> gr a b -> (r, gr a b) gfoldn f d b = threadList b (gfold1 f d b)  -- gfold :: ((Context a b) -> [Node]) -> ((Node,a) -> c -> d) ->@@ -95,8 +102,8 @@ -- gfold f d (b,u) l g = fst (gfoldn f d b u l g)  -- | Directed graph fold.-gfold :: Graph gr =>   ((Context a b) -> [Node])    -- ^ direction of fold-        -> ((Context a b) -> c -> d)    -- ^ depth aggregation+gfold :: (Graph gr) =>   (Context a b -> [Node])    -- ^ direction of fold+        -> (Context a b -> c -> d)    -- ^ depth aggregation         -> (Maybe d -> c -> c, c)      -- ^ breadth\/level aggregation         -> [Node]         -> gr a b

@@ -32,7 +32,7 @@ genUNodes n = zip [1..n] (repeat ())  -- | generate list of labeled nodes-genLNodes :: Enum a => a -> Int -> [LNode a]+genLNodes :: (Enum a) => a -> Int -> [LNode a] genLNodes q i = take i (zip [1..] [q..])  -- | denote unlabeled edges@@ -101,18 +101,18 @@ d1'   = mkGraphM (genLNodes 1 2) [(1,2,1)] d3'   = mkGraphM (genLNodes 1 3) [(1,2,1),(1,3,4),(2,3,2)] -ucycle :: Graph gr => Int -> gr () ()+ucycle :: (Graph gr) => Int -> gr () () ucycle n = mkUGraph vs (map (\v->(v,v `mod` n+1)) vs)            where vs = [1..n] -star :: Graph gr => Int -> gr () ()+star :: (Graph gr) => Int -> gr () () star n = mkUGraph [1..n] (map (\v->(1,v)) [2..n]) -ucycleM :: GraphM m gr => Int -> m (gr () ())+ucycleM :: (GraphM m gr) => Int -> m (gr () ()) ucycleM n = mkUGraphM vs (map (\v->(v,v `mod` n+1)) vs)             where vs = [1..n] -starM :: GraphM m gr => Int -> m (gr () ())+starM :: (GraphM m gr) => Int -> m (gr () ()) starM n = mkUGraphM [1..n] (map (\v->(1,v)) [2..n])  

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- (c) 1999-2005 by Martin Erwig [see file COPYRIGHT] -- | Static and Dynamic Inductive Graphs module Data.Graph.Inductive.Graph (@@ -33,101 +35,41 @@     DynGraph(..),     -- * Operations     -- ** Graph Folds and Maps-    ufold,gmap,nmap,emap,+    ufold,gmap,nmap,emap,nemap,     -- ** Graph Projection-    nodes,edges,newNodes,gelem,+    nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem,     -- ** Graph Construction and Destruction-    insNode,insEdge,delNode,delEdge,delLEdge,+    insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge,     insNodes,insEdges,delNodes,delEdges,     buildGr,mkUGraph,+    -- ** Subgraphs+    gfiltermap,nfilter,labnfilter,labfilter,subgraph,     -- ** Graph Inspection-    context,lab,neighbors,+    context,lab,neighbors,lneighbors,     suc,pre,lsuc,lpre,     out,inn,outdeg,indeg,deg,+    hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj,     equal,     -- ** Context Inspection-    node',lab',labNode',neighbors',+    node',lab',labNode',neighbors',lneighbors',     suc',pre',lpre',lsuc',     out',inn',outdeg',indeg',deg',     -- * Pretty-printing     prettify,-    prettyPrint+    prettyPrint,+    -- * Ordering of Graphs+    OrdGr(..) ) where --import Data.List (sortBy)---{- Signatures:---- basic operations-empty      ::    Graph gr => gr a b-isEmpty    ::    Graph gr => gr a b -> Bool-match      ::    Graph gr => Node -> gr a b -> Decomp gr a b-mkGraph    ::    Graph gr => [LNode a] -> [LEdge b] -> gr a b-(&)        :: DynGraph gr => Context a b -> gr a b -> gr a b---- graph folds and maps-ufold      :: Graph gr => ((Context a b) -> c -> c) -> c -> gr a b -> c-gmap       :: Graph gr => (Context a b -> Context c d) -> gr a b -> gr c d-nmap       :: Graph gr => (a -> c) -> gr a b -> gr c b-emap       :: Graph gr => (b -> c) -> gr a b -> gr a c---- graph projection-matchAny   :: Graph gr => gr a b -> GDecomp g a b-nodes      :: Graph gr => gr a b -> [Node]-edges      :: Graph gr => gr a b -> [Edge]-labNodes   :: Graph gr => gr a b -> [LNode a]-labEdges   :: Graph gr => gr a b -> [LEdge b]-newNodes   :: Graph gr => Int -> gr a b -> [Node]-noNodes    :: Graph gr => gr a b -> Int-nodeRange  :: Graph gr => gr a b -> (Node,Node)-gelem      :: Graph gr => Node -> gr a b -> Bool---- graph construction & destruction-insNode    :: DynGraph gr => LNode a   -> gr a b -> gr a b-insEdge    :: DynGraph gr => LEdge b   -> gr a b -> gr a b-delNode    ::    Graph gr => Node      -> gr a b -> gr a b-delEdge    :: DynGraph gr => Edge      -> gr a b -> gr a b-delLEdge   :: (DynGraph gr, Eq b) =>-                             LEdge b   -> gr a b -> gr a b-insNodes   :: DynGraph gr => [LNode a] -> gr a b -> gr a b-insEdges   :: DynGraph gr => [LEdge b] -> gr a b -> gr a b-delNodes   ::    Graph gr => [Node]    -> gr a b -> gr a b-delEdges   :: DynGraph gr => [Edge]    -> gr a b -> gr a b-buildGr    :: DynGraph gr => [Context a b] -> gr a b-mkUGraph   :: DynGraph gr => [Node] -> [Edge] -> gr () ()---- graph inspection-context    :: Graph gr => gr a b -> Node -> Context a b-lab        :: Graph gr => gr a b -> Node -> Maybe a-neighbors  :: Graph gr => gr a b -> Node -> [Node]-suc        :: Graph gr => gr a b -> Node -> [Node]-pre        :: Graph gr => gr a b -> Node -> [Node]-lsuc       :: Graph gr => gr a b -> Node -> [(Node,b)]-lpre       :: Graph gr => gr a b -> Node -> [(Node,b)]-out        :: Graph gr => gr a b -> Node -> [LEdge b]-inn        :: Graph gr => gr a b -> Node -> [LEdge b]-outdeg     :: Graph gr => gr a b -> Node -> Int-indeg      :: Graph gr => gr a b -> Node -> Int-deg        :: Graph gr => gr a b -> Node -> Int---- context inspection-node'      :: Context a b -> Node-lab'       :: Context a b -> a-labNode'   :: Context a b -> LNode a-neighbors' :: Context a b -> [Node]-suc'       :: Context a b -> [Node]-pre'       :: Context a b -> [Node]-lpre'      :: Context a b -> [(Node,b)]-lsuc'      :: Context a b -> [(Node,b)]-out'       :: Context a b -> [LEdge b]-inn'       :: Context a b -> [LEdge b]-outdeg'    :: Context a b -> Int-indeg'     :: Context a b -> Int-deg'       :: Context a b -> Int+import           Control.Arrow (first)+import           Data.Function (on)+import qualified Data.IntSet   as IntSet+import           Data.List     (delete, foldl', groupBy, sort, sortBy, (\\))+import           Data.Maybe    (fromMaybe, isJust) --}+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mappend)+#endif  -- | Unlabeled node type  Node   = Int@@ -146,11 +88,21 @@ -- | Unlabeled path type Path    = [Node] -- | Labeled path-newtype LPath a = LP [LNode a]+newtype LPath a = LP { unLPath :: [LNode a] } -instance Show a => Show (LPath a) where+instance (Show a) => Show (LPath a) where   show (LP xs) = show xs +instance (Eq a) => Eq (LPath a) where+  (LP [])        == (LP [])        = True+  (LP ((_,x):_)) == (LP ((_,y):_)) = x==y+  (LP _)         == (LP _)         = False++instance (Ord a) => Ord (LPath a) where+  compare (LP [])        (LP [])        = EQ+  compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y+  compare _ _ = error "LPath: cannot compare two empty paths"+ -- | Quasi-unlabeled path type UPath   = [UNode] @@ -172,184 +124,273 @@  -- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes' class Graph gr where-  -- essential operations+  {-# MINIMAL empty, isEmpty, match, mkGraph, labNodes #-}+   -- | An empty 'Graph'.   empty     :: gr a b+   -- | True if the given 'Graph' is empty.   isEmpty   :: gr a b -> Bool+   -- | Decompose a 'Graph' into the 'MContext' found for the given node and the   -- remaining 'Graph'.   match     :: Node -> gr a b -> Decomp gr a b+   -- | Create a 'Graph' from the list of 'LNode's and 'LEdge's.+  --+  --   For graphs that are also instances of 'DynGraph', @mkGraph ns+  --   es@ should be equivalent to @('insEdges' es . 'insNodes' ns)+  --   'empty'@.   mkGraph   :: [LNode a] -> [LEdge b] -> gr a b+   -- | A list of all 'LNode's in the 'Graph'.   labNodes  :: gr a b -> [LNode a]-  -- derived operations+   -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node'   -- and the remaining 'Graph'.   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+   -- | The number of 'Node's in a 'Graph'.   noNodes   :: gr a b -> Int+  noNodes = length . labNodes+   -- | The minimum and maximum 'Node' in a 'Graph'.   nodeRange :: gr a b -> (Node,Node)+  nodeRange g+    | isEmpty g = error "nodeRange of empty graph"+    | otherwise = (minimum vs, maximum vs)+    where+      vs = nodes g+   -- | A list of all 'LEdge's in the 'Graph'.   labEdges  :: gr a b -> [LEdge b]-  -- default implementation of derived operations-  matchAny g = case labNodes g of-                 []      -> error "Match Exception, Empty Graph"-                 (v,_):_ -> (c,g') where (Just c,g') = match v g-  noNodes = length . labNodes-  nodeRange g = (minimum vs,maximum vs) where vs = map fst (labNodes g)-  labEdges = ufold (\(_,v,_,s)->((map (\(l,w)->(v,w,l)) s)++)) []-+  labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) [] -class Graph gr => DynGraph gr where+class (Graph gr) => DynGraph gr where   -- | Merge the 'Context' into the 'DynGraph'.   (&) :: Context a b -> gr a b -> gr a b - -- | Fold a function over the graph.-ufold :: Graph gr => ((Context a b) -> c -> c) -> c -> gr a b -> c-ufold f u g | isEmpty g = u-            | otherwise = f c (ufold f u g')-            where (c,g') = matchAny g+ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c+ufold f u g+  | isEmpty g = u+  | otherwise = f c (ufold f u g')+  where+    (c,g') = matchAny g  -- | Map a function over the graph.-gmap :: DynGraph gr => (Context a b -> Context c d) -> gr a b -> gr c d+gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d gmap f = ufold (\c->(f c&)) empty  -- | Map a function over the 'Node' labels in a graph.-nmap :: DynGraph gr => (a -> c) -> gr a b -> gr c b+nmap :: (DynGraph gr) => (a -> c) -> gr a b -> gr c b nmap f = gmap (\(p,v,l,s)->(p,v,f l,s))  -- | Map a function over the 'Edge' labels in a graph.-emap :: DynGraph gr => (b -> c) -> gr a b -> gr a c+emap :: (DynGraph gr) => (b -> c) -> gr a b -> gr a c emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s))-         where map1 g = map (\(l,v)->(g l,v))+  where+    map1 g = map (first g) +-- | Map functions over both the 'Node' and 'Edge' labels in a graph.+nemap :: (DynGraph gr) => (a -> c) -> (b -> d) -> gr a b -> gr c d+nemap fn fe = gmap (\(p,v,l,s) -> (fe' p,v,fn l,fe' s))+  where+    fe' = map (first fe)+ -- | List all 'Node's in the 'Graph'.-nodes :: Graph gr => gr a b -> [Node]+nodes :: (Graph gr) => gr a b -> [Node] nodes = map fst . labNodes  -- | List all 'Edge's in the 'Graph'.-edges :: Graph gr => gr a b -> [Edge]-edges = map (\(v,w,_)->(v,w)) . labEdges+edges :: (Graph gr) => gr a b -> [Edge]+edges = map toEdge . labEdges +-- | Drop the label component of an edge.+toEdge :: LEdge b -> Edge+toEdge (v,w,_) = (v,w)++-- | Add a label to an edge.+toLEdge :: Edge -> b -> LEdge b+toLEdge (v,w) l = (v,w,l)++-- | The label in an edge.+edgeLabel :: LEdge b -> b+edgeLabel (_,_,l) = l+ -- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'.-newNodes :: Graph gr => Int -> gr a b -> [Node]-newNodes i g = [n+1..n+i] where (_,n) = nodeRange g+newNodes :: (Graph gr) => Int -> gr a b -> [Node]+newNodes i g+  | isEmpty g = [0..i-1]+  | otherwise = [n+1..n+i]+  where+    (_,n) = nodeRange g  -- | 'True' if the 'Node' is present in the 'Graph'.-gelem :: Graph gr => Node -> gr a b -> Bool-gelem v g = case match v g of {(Just _,_) -> True; _ -> False}+gelem :: (Graph gr) => Node -> gr a b -> Bool+gelem v = isJust . fst . match v  -- | Insert a 'LNode' into the 'Graph'.-insNode :: DynGraph gr => LNode a -> gr a b -> gr a b+insNode :: (DynGraph gr) => LNode a -> gr a b -> gr a b insNode (v,l) = (([],v,l,[])&) {-# NOINLINE [0] insNode #-}  -- | Insert a 'LEdge' into the 'Graph'.-insEdge :: DynGraph gr => LEdge b -> gr a b -> gr a b+insEdge :: (DynGraph gr) => LEdge b -> gr a b -> gr a b insEdge (v,w,l) g = (pr,v,la,(l,w):su) & g'-                    where (Just (pr,_,la,su),g') = match v g+  where+    (mcxt,g') = match v g+    (pr,_,la,su) = fromMaybe+                     (error ("insEdge: cannot add edge from non-existent vertex " ++ show v))+                     mcxt  -- | Remove a 'Node' from the 'Graph'.-delNode :: Graph gr => Node -> gr a b -> gr a b+delNode :: (Graph gr) => Node -> gr a b -> gr a b delNode v = delNodes [v]  -- | Remove an 'Edge' from the 'Graph'.-delEdge :: DynGraph gr => Edge -> gr a b -> gr a b+--+--   NOTE: in the case of multiple edges, this will delete /all/ such+--   edges from the graph as there is no way to distinguish between+--   them.  If you need to delete only a single such edge, please use+--   'delLEdge'.+delEdge :: (DynGraph gr) => Edge -> gr a b -> gr a b delEdge (v,w) g = case match v g of-                  (Nothing,_)        -> g-                  (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g'+                    (Nothing,_)          -> g+                    (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g'  -- | Remove an 'LEdge' from the 'Graph'.+--+--   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 'delAllLedges'. delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b-delLEdge (v,w,b) g = case match v g of-                  (Nothing,_)        -> g-                  (Just (p,v',l,s),g') -> (p,v',l,filter (\(x,n) -> x /= b || n /= w) s) & g'+delLEdge = delLEdgeBy delete +-- | Remove all edges equal to the one specified.+delAllLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b+delAllLEdge = delLEdgeBy (filter . (/=))++delLEdgeBy :: (DynGraph gr) => ((b,Node) -> Adj b -> Adj b)+              -> LEdge b -> gr a b -> gr a b+delLEdgeBy f (v,w,b) g = case match v g of+                           (Nothing,_)          -> g+                           (Just (p,v',l,s),g') -> (p,v',l,f (b,w) s) & g'+ -- | Insert multiple 'LNode's into the 'Graph'.-insNodes   :: DynGraph gr => [LNode a] -> gr a b -> gr a b-insNodes vs g = foldr insNode g vs+insNodes   :: (DynGraph gr) => [LNode a] -> gr a b -> gr a b+insNodes vs g = foldl' (flip insNode) g vs  -- | Insert multiple 'LEdge's into the 'Graph'.-insEdges :: DynGraph gr => [LEdge b] -> gr a b -> gr a b-insEdges es g = foldr insEdge g es+insEdges :: (DynGraph gr) => [LEdge b] -> gr a b -> gr a b+insEdges es g = foldl' (flip insEdge) g es  -- | Remove multiple 'Node's from the 'Graph'.-delNodes :: Graph gr => [Node] -> gr a b -> gr a b-delNodes []     g = g-delNodes (v:vs) g = delNodes vs (snd (match v g))+delNodes :: (Graph gr) => [Node] -> gr a b -> gr a b+delNodes vs g = foldl' (snd .: flip match) g vs  -- | Remove multiple 'Edge's from the 'Graph'.-delEdges :: DynGraph gr => [Edge]    -> gr a b -> gr a b-delEdges es g = foldr delEdge g es+delEdges :: (DynGraph gr) => [Edge] -> gr a b -> gr a b+delEdges es g = foldl' (flip delEdge) g es  -- | Build a 'Graph' from a list of 'Context's.-buildGr :: DynGraph gr => [Context a b] -> gr a b+--+--   The list should be in the order such that earlier 'Context's+--   depend upon later ones (i.e. as produced by @'ufold' (:) []@).+buildGr :: (DynGraph gr) => [Context a b] -> gr a b buildGr = foldr (&) empty --- mkGraph :: DynGraph gr => [LNode a] -> [LEdge b] -> gr a b--- mkGraph vs es = (insEdges es . insNodes vs) empty- -- | Build a quasi-unlabeled 'Graph'.-mkUGraph :: Graph gr => [Node] -> [Edge] -> gr () ()+mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () () mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es)-   where labUEdges = map (\(v,w)->(v,w,()))-         labUNodes = map (\v->(v,()))+   where+     labUEdges = map (`toLEdge` ())+     labUNodes = map (flip (,) ()) +-- | Build a graph out of the contexts for which the predicate is+-- true.+gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d+gfiltermap f = ufold (maybe id (&) . f) empty++-- | Returns the subgraph only containing the labelled nodes which+-- satisfy the given predicate.+labnfilter :: Graph gr => (LNode a -> Bool) -> gr a b -> gr a b+labnfilter p gr = delNodes (map fst . filter (not . p) $ labNodes gr) gr++-- | Returns the subgraph only containing the nodes which satisfy the+-- given predicate.+nfilter :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b+nfilter f = labnfilter (f . fst)++-- | Returns the subgraph only containing the nodes whose labels+-- satisfy the given predicate.+labfilter :: DynGraph gr => (a -> Bool) -> gr a b -> gr a b+labfilter f = labnfilter (f . snd)++-- | Returns the subgraph induced by the supplied nodes.+subgraph :: DynGraph gr => [Node] -> gr a b -> gr a b+subgraph vs = let vs' = IntSet.fromList vs+              in nfilter (`IntSet.member` vs')+ -- | Find the context for the given 'Node'.  Causes an error if the 'Node' is -- not present in the 'Graph'.-context :: Graph gr => gr a b -> Node -> Context a b-context g v = case match v g of-                (Nothing,_) -> error ("Match Exception, Node: "++show v)-                (Just c,_)  -> c+context :: (Graph gr) => gr a b -> Node -> Context a b+context g v = fromMaybe (error ("Match Exception, Node: "++show v))+                        (fst (match v g))  -- | Find the label for a 'Node'.-lab :: Graph gr => gr a b -> Node -> Maybe a-lab g v = fst (match v g) >>= return.lab'+lab :: (Graph gr) => gr a b -> Node -> Maybe a+lab g v = fmap lab' . fst $ match v g  -- | Find the neighbors for a 'Node'.-neighbors :: Graph gr => gr a b -> Node -> [Node]-neighbors = (\(p,_,_,s) -> map snd (p++s)) .: context+neighbors :: (Graph gr) => gr a b -> Node -> [Node]+neighbors = map snd .: lneighbors +-- | Find the labelled links coming into or going from a 'Context'.+lneighbors :: (Graph gr) => gr a b -> Node -> Adj b+lneighbors = maybe [] lneighbors' .: mcontext+ -- | Find all 'Node's that have a link from the given 'Node'.-suc :: Graph gr => gr a b -> Node -> [Node]+suc :: (Graph gr) => gr a b -> Node -> [Node] suc = map snd .: context4l  -- | Find all 'Node's that link to to the given 'Node'.-pre :: Graph gr => gr a b -> Node -> [Node]+pre :: (Graph gr) => gr a b -> Node -> [Node] pre = map snd .: context1l  -- | Find all 'Node's that are linked from the given 'Node' and the label of -- each link.-lsuc :: Graph gr => gr a b -> Node -> [(Node,b)]+lsuc :: (Graph gr) => gr a b -> Node -> [(Node,b)] lsuc = map flip2 .: context4l  -- | Find all 'Node's that link to the given 'Node' and the label of each link.-lpre :: Graph gr => gr a b -> Node -> [(Node,b)]+lpre :: (Graph gr) => gr a b -> Node -> [(Node,b)] lpre = map flip2 .: context1l  -- | Find all outward-bound 'LEdge's for the given 'Node'.-out :: Graph gr => gr a b -> Node -> [LEdge b]+out :: (Graph gr) => gr a b -> Node -> [LEdge b] out g v = map (\(l,w)->(v,w,l)) (context4l g v)  -- | Find all inward-bound 'LEdge's for the given 'Node'.-inn :: Graph gr => gr a b -> Node -> [LEdge b]+inn :: (Graph gr) => gr a b -> Node -> [LEdge b] inn g v = map (\(l,w)->(w,v,l)) (context1l g v)  -- | The outward-bound degree of the 'Node'.-outdeg :: Graph gr => gr a b -> Node -> Int+outdeg :: (Graph gr) => gr a b -> Node -> Int outdeg = length .: context4l  -- | The inward-bound degree of the 'Node'.-indeg :: Graph gr => gr a b -> Node -> Int+indeg :: (Graph gr) => gr a b -> Node -> Int indeg  = length .: context1l  -- | The degree of the 'Node'.-deg :: Graph gr => gr a b -> Node -> Int-deg = (\(p,_,_,s) -> length p+length s) .: context+deg :: (Graph gr) => gr a b -> Node -> Int+deg = deg' .: context  -- | The 'Node' in a 'Context'. node' :: Context a b -> Node@@ -367,6 +408,10 @@ neighbors' :: Context a b -> [Node] neighbors' (p,_,_,s) = map snd p++map snd s +-- | All labelled links coming into or going from a 'Context'.+lneighbors' :: Context a b -> Adj b+lneighbors' (p,_,_,s) = p ++ s+ -- | All 'Node's linked to in a 'Context'. suc' :: Context a b -> [Node] suc' = map snd . context4l'@@ -403,41 +448,67 @@ deg' :: Context a b -> Int deg' (p,_,_,s) = length p+length s +-- | Checks if there is a directed edge between two nodes.+hasEdge :: Graph gr => gr a b -> Edge -> Bool+hasEdge gr (v,w) = w `elem` suc gr v --- graph equality----nodeComp :: Eq b => LNode b -> LNode b -> Ordering-nodeComp n@(v,_) n'@(w,_) | n == n'   = EQ-                          | v<w       = LT-                          | otherwise = GT+-- | Checks if there is an undirected edge between two nodes.+hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool+hasNeighbor gr v w = w `elem` neighbors gr v -slabNodes :: (Eq a,Graph gr) => gr a b -> [LNode a]-slabNodes = sortBy nodeComp . labNodes+-- | Checks if there is a labelled edge between two nodes.+hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool+hasLEdge gr (v,w,l) = (w,l) `elem` lsuc gr v -edgeComp :: Eq b => LEdge b -> LEdge b -> Ordering-edgeComp e@(v,w,_) e'@(x,y,_) | e == e'              = EQ-                              | v<x || (v==x && w<y) = LT-                              | otherwise            = GT+-- | Checks if there is an undirected labelled edge between two nodes.+hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> (b,Node) -> Bool+hasNeighborAdj gr v a = a `elem` lneighbors gr v -slabEdges :: (Eq b,Graph gr) => gr a b -> [LEdge b]-slabEdges = sortBy edgeComp . labEdges+----------------------------------------------------------------------+-- GRAPH EQUALITY+---------------------------------------------------------------------- --- instance (Eq a,Eq b,Graph gr) => Eq (gr a b) where---   g == g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g'+slabNodes :: (Graph gr) => gr a b -> [LNode a]+slabNodes = sortBy (compare `on` fst) . labNodes +glabEdges :: (Graph gr) => gr a b -> [GroupEdges b]+glabEdges = map (GEs . groupLabels)+            . groupBy ((==) `on` toEdge)+            . sortBy (compare `on` toEdge)+            . labEdges+  where+    groupLabels les = toLEdge (toEdge (head les)) (map edgeLabel les)+ equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool-equal g g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g'+equal g g' = slabNodes g == slabNodes g' && glabEdges g == glabEdges g'+-- This assumes that nodes aren't repeated (which shouldn't happen for+-- sane graph instances).  If node IDs are repeated, then the usage of+-- slabNodes cannot guarantee stable ordering. +-- Newtype wrapper just to test for equality of multiple edges.  This+-- is needed because without an Ord constraint on `b' it is not+-- possible to guarantee a stable ordering on edge labels.+newtype GroupEdges b = GEs (LEdge [b])+  deriving (Show, Read) +instance (Eq b) => Eq (GroupEdges b) where+  (GEs (v1,w1,bs1)) == (GEs (v2,w2,bs2)) = v1 == v2+                                           && w1 == w2+                                           && eqLists bs1 bs2++eqLists :: (Eq a) => [a] -> [a] -> Bool+eqLists xs ys = null (xs \\ ys) && null (ys \\ xs)+-- OK to use \\ here as we want each value in xs to cancel a *single*+-- value in ys.+ ---------------------------------------------------------------------- -- UTILITIES ---------------------------------------------------------------------- - -- auxiliary functions used in the implementation of the -- derived class members ---(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d -- f .: g = \x y->f (g x y) -- f .: g = (f .) . g -- (.:) f = ((f .) .)@@ -449,12 +520,15 @@  -- projecting on context elements ---context1l :: Graph gr => gr a b -> Node -> Adj b-context1l = context1l' .: context+context1l :: (Graph gr) => gr a b -> Node -> Adj b+context1l = maybe [] context1l' .: mcontext -context4l :: Graph gr => gr a b -> Node -> Adj b-context4l = context4l' .: context+context4l :: (Graph gr) => gr a b -> Node -> Adj b+context4l = maybe [] context4l' .: mcontext +mcontext :: (Graph gr) => gr a b -> Node -> MContext a b+mcontext = fst .: flip match+ context1l' :: Context a b -> Adj b context1l' (p,v,_,s) = p++filter ((==v).snd) s @@ -465,12 +539,10 @@ -- PRETTY PRINTING ---------------------------------------------------------------------- --- ufold :: Graph gr => (Context a b -> c -> c) -> c -> gr a b -> c- -- | 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 g = ufold showsContext id g ""+prettify g = foldr (showsContext . context g) id (nodes g) ""   where     showsContext (_,n,l,s) sg = shows n . (':':) . shows l                                 . showString "->" . shows s@@ -479,3 +551,20 @@ -- | Pretty-print the graph to stdout. prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO () prettyPrint = putStr . prettify++----------------------------------------------------------------------+-- Ordered Graph+----------------------------------------------------------------------++-- | OrdGr comes equipped with an Ord instance, so that graphs can be+--   used as e.g. Map keys.+newtype OrdGr gr a b = OrdGr { unOrdGr :: gr a b }+  deriving (Read,Show)++instance (Graph gr, Ord a, Ord b) => Eq (OrdGr gr a b) where+  g1 == g2 = compare g1 g2 == EQ++instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where+  compare (OrdGr g1) (OrdGr g2) =+    (compare `on` sort . labNodes) g1 g2+    `mappend` (compare `on` sort . labEdges) g1 g2

@@ -2,63 +2,73 @@ module Data.Graph.Inductive.Internal.Heap(     -- * Type     Heap(..),+    prettyHeap,+    printPrettyHeap,     -- * Operations     empty,unit,insert,merge,mergeAll,     isEmpty,findMin,deleteMin,splitMin,     build, toList, heapsort ) where +import Control.DeepSeq (NFData (..))+import Text.Show       (showListWith)  data Heap a b = Empty | Node a b [Heap a b]-     deriving Eq+     deriving (Eq, Show, Read) -showsHeap :: (Show a,Ord a,Show b) => Heap a b -> ShowS-showsHeap Empty             = id-showsHeap (Node key val []) = shows key . (": "++) . shows val-showsHeap (Node key val hs) = shows key . (": "++) . shows val .  (' ':) . shows hs+instance (NFData a, NFData b) => NFData (Heap a b) where+  rnf Empty         = ()+  rnf (Node a b hs) = rnf a `seq` rnf b `seq` rnf hs -instance (Show a,Ord a,Show b) => Show (Heap a b) where-  showsPrec _ d = showsHeap d+prettyHeap :: (Show a, Show b) => Heap a b -> String+prettyHeap = (`showsHeap` "")+  where+    showsHeap Empty             = id+    showsHeap (Node key val []) = shows key . (": "++) . shows val+    showsHeap (Node key val hs) = shows key . (": "++) . shows val+                                  .  (' ':) . showListWith showsHeap hs +printPrettyHeap :: (Show a, Show b) => Heap a b -> IO ()+printPrettyHeap = putStrLn . prettyHeap  ---------------------------------------------------------------------- -- MAIN FUNCTIONS ---------------------------------------------------------------------- -empty :: Ord a => Heap a b+empty :: Heap a b empty = Empty -unit :: Ord a => a -> b -> Heap a b+unit :: a -> b -> Heap a b unit key val = Node key val [] -insert :: Ord a => (a, b) -> Heap a b -> Heap a b-insert (key, val) h = merge (unit key val) h+insert :: (Ord a) => (a, b) -> Heap a b -> Heap a b+insert (key, val) = merge (unit key val) -merge :: Ord a => Heap a b -> Heap a b -> Heap a b+merge :: (Ord a) => Heap a b -> Heap a b -> Heap a b merge h Empty = h merge Empty h = h merge h@(Node key1 val1 hs) h'@(Node key2 val2 hs')     | key1<key2 = Node key1 val1 (h':hs)     | otherwise = Node key2 val2 (h:hs') -mergeAll:: Ord a => [Heap a b] -> Heap a b+mergeAll:: (Ord a) => [Heap a b] -> Heap a b mergeAll []        = Empty mergeAll [h]       = h mergeAll (h:h':hs) = merge (merge h h') (mergeAll hs) -isEmpty :: Ord a => Heap a b -> Bool+isEmpty :: Heap a b -> Bool isEmpty Empty = True isEmpty _     = False -findMin :: Ord a => Heap a b -> (a, b)+findMin :: Heap a b -> (a, b) findMin Empty      = error "Heap.findMin: empty heap" findMin (Node key val _) = (key, val) -deleteMin :: Ord a => Heap a b -> Heap a b+deleteMin :: (Ord a) => Heap a b -> Heap a b deleteMin Empty             = Empty deleteMin (Node _ _ hs) = mergeAll hs -splitMin :: Ord a => Heap a b -> (a,b,Heap a b)+splitMin :: (Ord a) => Heap a b -> (a,b,Heap a b) splitMin Empty             = error "Heap.splitMin: empty heap" splitMin (Node key val hs) = (key,val,mergeAll hs) @@ -68,16 +78,16 @@ ----------------------------------------------------------------------  -build :: Ord a => [(a,b)] -> Heap a b+build :: (Ord a) => [(a,b)] -> Heap a b build = foldr insert Empty -toList :: Ord a => Heap a b -> [(a,b)]+toList :: (Ord a) => Heap a b -> [(a,b)] toList Empty = [] toList h = x:toList r            where (x,r) = (findMin h,deleteMin h) -heapsort :: Ord a => [a] -> [a]-heapsort = (map fst) . toList . build . map (\x->(x,x))+heapsort :: (Ord a) => [a] -> [a]+heapsort = map fst . toList . build . map (\x->(x,x)) {- l :: (Num a) => [a] l  = [6,9,2,13,6,8,14,9,10,7,5]

@@ -5,6 +5,7 @@     mkQueue, queuePut, queuePutList, queueGet, queueEmpty ) where +import Data.List (foldl')  data Queue a = MkQueue [a] [a] @@ -15,12 +16,11 @@ queuePut item (MkQueue ins outs) = MkQueue (item:ins) outs  queuePutList :: [a] -> Queue a -> Queue a-queuePutList [] q     = q-queuePutList (x:xs) q = queuePutList xs (queuePut x q)+queuePutList xs q = foldl' (flip queuePut) q xs  queueGet :: Queue a -> (a, Queue a) queueGet (MkQueue ins (item:rest)) = (item, MkQueue ins rest) queueGet (MkQueue ins []) = queueGet (MkQueue [] (reverse ins))  queueEmpty :: Queue a -> Bool-queueEmpty (MkQueue ins outs) = (null ins) && (null outs)+queueEmpty (MkQueue ins outs) = null ins && null outs

@@ -11,18 +11,6 @@  import Data.Graph.Inductive.Graph --instance Eq a => Eq (LPath a) where-  (LP [])        == (LP [])        = True-  (LP ((_,x):_)) == (LP ((_,y):_)) = x==y-  (LP _)         == (LP _)         = False--instance Ord a => Ord (LPath a) where-  compare (LP [])        (LP [])        = EQ-  compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y-  compare _ _ = error "LPath: cannot compare to empty paths"-- type LRTree a = [LPath a] type RTree = [Path] @@ -33,10 +21,10 @@  -- | Find the first path in a tree that starts with the given node findP :: Node -> LRTree a -> [LNode a]-findP _ []                                  = []-findP v ((LP []):ps)                        = findP v ps-findP v ((LP (p@((w,_):_))):ps) | v==w      = p-                                | otherwise = findP v ps+findP _ []                                = []+findP v (LP []:ps)                        = findP v ps+findP v (LP (p@((w,_):_)):ps) | v==w      = p+                              | otherwise = findP v ps  getPath :: Node -> RTree -> Path getPath v = reverse . first (\(w:_)->w==v)

@@ -25,7 +25,7 @@ instance Thread (Graph a b) Node (MContext a b) where   split = match -instance D.Discrete a => Thread (D.Diet a) a a where+instance (D.Discrete a) => Thread (D.Diet a) a a where   split x s = (x,D.delete x s) -} @@ -76,7 +76,7 @@  --  (3) abstract from split ---threadList' :: (Collect r c) -> (Split t i r) -> [i] -> t -> (c,t)+threadList' :: Collect r c -> Split t i r -> [i] -> t -> (c,t) threadList' (_,c) _ []         t = (c,t) threadList' (f,c) split (i:is) t = threadList' (f,f r c) split is t'                                    where (r,t') = split i t@@ -88,7 +88,7 @@    ==> therefore, we define a correpsonding operator for folding        bottom-up/from right. -}-threadList :: (Collect r c) -> (Split t i r) -> [i] -> t -> (c,t)+threadList :: Collect r c -> Split t i r -> [i] -> t -> (c,t) threadList (_,c) _ []     t  = (c,t) threadList (f,c) split (i:is) t = (f r c',t'')                                   where (r,t')   = split i t@@ -100,7 +100,7 @@ --     threading with "continuation" c, and ignore Nothing-values, ie, --     stop threading and return current data structure. ----- threadMaybe' :: (r -> b) -> (Split t i r) -> (e -> f -> (Maybe i,t))+-- threadMaybe' :: (r -> b) -> Split t i r -> (e -> f -> (Maybe i,t)) --                 -> e -> f -> (Maybe b,t)  type SplitM t i r = Split t i (Maybe r)

@@ -20,6 +20,7 @@  import Data.Graph.Inductive.Graph +{-# ANN module "HLint: ignore Redundant lambda" #-}  ---------------------------------------------------------------------- -- MONADIC GRAPH CLASS@@ -38,36 +39,46 @@  -- Monadic Graph ---class Monad m => GraphM m gr where-  -- essential operations+class (Monad m) => GraphM m gr where+  {-# MINIMAL emptyM, isEmptyM, matchM, mkGraphM, labNodesM #-}+   emptyM     :: m (gr a b)+   isEmptyM   :: m (gr a b) -> m Bool+   matchM     :: Node -> m (gr a b) -> m (Decomp gr a b)+   mkGraphM   :: [LNode a] -> [LEdge b] -> m (gr a b)+   labNodesM  :: m (gr a b) -> m [LNode a]-  -- derived operations+   matchAnyM  :: m (gr a b) -> m (GDecomp gr a b)-  noNodesM   :: m (gr a b) -> m Int-  nodeRangeM :: m (gr a b) -> m (Node,Node)-  labEdgesM  :: m (gr a b) -> m [LEdge b]-  -- default implementation of derived operations   matchAnyM g = do vs <- labNodesM g                    case vs of-                     []      -> error "Match Exception, Empty Graph"+                     []      -> fail "Match Exception, Empty Graph"                      (v,_):_ -> do (Just c,g') <- matchM v g                                    return (c,g')++  noNodesM   :: m (gr a b) -> m Int   noNodesM = labNodesM >>. length-  nodeRangeM g = do vs <- labNodesM g-                    let vs' = map fst vs-                    return (minimum vs',maximum vs')-  labEdgesM = ufoldM (\(p,v,_,s)->(((map (i v) p)++(map (o v) s))++)) []-              where o v = \(l,w)->(v,w,l)-                    i v = \(l,w)->(w,v,l) +  nodeRangeM :: m (gr a b) -> m (Node,Node)+  nodeRangeM g = do isE <- isEmptyM g+                    if isE+                       then fail "nodeRangeM of empty graph"+                       else do vs <- nodesM g+                               return (minimum vs,maximum vs) +  labEdgesM  :: m (gr a b) -> m [LEdge b]+  labEdgesM = ufoldM (\(p,v,_,s)->((map (i v) p ++ map (o v) s)++)) []+    where+      o v = \(l,w)->(v,w,l)+      i v = \(l,w)->(w,v,l)++ -- composing a monadic function with a non-monadic one ---(>>.) :: Monad m => (m a -> m b) -> (b -> c) -> (m a -> m c)+(>>.) :: (Monad m) => (m a -> m b) -> (b -> c) -> m a -> m c f >>. g = (>>= return . g) . f  @@ -79,7 +90,7 @@ --  -- | graph fold-ufoldM :: GraphM m gr => ((Context a b) -> c -> c) -> c -> m (gr a b) -> m c+ufoldM :: (GraphM m gr) => (Context a b -> c -> c) -> c -> m (gr a b) -> m c ufoldM f u g = do b <- isEmptyM g                   if b then return u                        else do (c,g') <- matchAnyM g@@ -90,75 +101,81 @@ -- (additional) graph projection -- [noNodes, nodeRange, labNodes, labEdges are defined in class Graph] ---nodesM :: GraphM m gr => m (gr a b) -> m [Node]+nodesM :: (GraphM m gr) => m (gr a b) -> m [Node] nodesM = labNodesM >>. map fst -edgesM :: GraphM m gr => m (gr a b) -> m [Edge]+edgesM :: (GraphM m gr) => m (gr a b) -> m [Edge] edgesM =  labEdgesM >>. map (\(v,w,_)->(v,w)) -newNodesM :: GraphM m gr => Int -> m (gr a b) -> m [Node]-newNodesM i g = do (_,n) <- nodeRangeM g-                   return [n+1..n+i]+newNodesM :: (GraphM m gr) => Int -> m (gr a b) -> m [Node]+newNodesM i g = do isE <- isEmptyM g+                   if isE+                      then return [0..i-1]+                      else do (_,n) <- nodeRangeM g+                              return [n+1..n+i]   -- graph construction & destruction ---delNodeM :: GraphM m gr => Node -> m (gr a b) -> m (gr a b)+delNodeM :: (GraphM m gr) => Node -> m (gr a b) -> m (gr a b) delNodeM v = delNodesM [v] -delNodesM :: GraphM m gr => [Node] -> m (gr a b) -> m (gr a b)+delNodesM :: (GraphM m gr) => [Node] -> m (gr a b) -> m (gr a b) delNodesM []     g = g delNodesM (v:vs) g = do (_,g') <- matchM v g                         delNodesM vs (return g') -mkUGraphM :: GraphM m gr => [Node] -> [Edge] -> m (gr () ())+mkUGraphM :: (GraphM m gr) => [Node] -> [Edge] -> m (gr () ()) mkUGraphM vs es = mkGraphM (labUNodes vs) (labUEdges es) -labUEdges = map (\(v,w)->(v,w,()))+labUEdges :: [Edge] -> [LEdge ()]+labUEdges = map (`toLEdge` ())++labUNodes :: [Node] -> [LNode ()] labUNodes = map (\v->(v,()))   -- graph inspection (for a particular node) ---onMatch :: GraphM m gr => (Context a b -> c) -> c -> m (gr a b) -> Node -> m c+onMatch :: (GraphM m gr) => (Context a b -> c) -> c -> m (gr a b) -> Node -> m c onMatch f u g v = do (x,_) <- matchM v g                      return (case x of {Nothing -> u; Just c -> f c}) -contextM :: GraphM m gr => m (gr a b) -> Node -> m (Context a b)+contextM :: (GraphM m gr) => m (gr a b) -> Node -> m (Context a b) contextM g v = onMatch id (error ("Match Exception, Node: "++show v)) g v -labM :: GraphM m gr => m (gr a b) -> Node -> m (Maybe a)+labM :: (GraphM m gr) => m (gr a b) -> Node -> m (Maybe a) labM = onMatch (Just . lab') Nothing  {--neighbors :: GraphM m gr => m (gr a b) -> Node -> [Node]+neighbors :: (GraphM m gr) => m (gr a b) -> Node -> [Node] neighbors = (\(p,_,_,s) -> map snd (p++s)) .: context -suc :: GraphM m gr => m (gr a b) -> Node -> [Node]+suc :: (GraphM m gr) => m (gr a b) -> Node -> [Node] suc = map snd .: context4 -pre :: GraphM m gr => m (gr a b) -> Node -> [Node]+pre :: (GraphM m gr) => m (gr a b) -> Node -> [Node] pre = map snd .: context1 -lsuc :: GraphM m gr => m (gr a b) -> Node -> [(Node,b)]+lsuc :: (GraphM m gr) => m (gr a b) -> Node -> [(Node,b)] lsuc = map flip2 .: context4 -lpre :: GraphM m gr => m (gr a b) -> Node -> [(Node,b)]+lpre :: (GraphM m gr) => m (gr a b) -> Node -> [(Node,b)] lpre = map flip2 .: context1 -out :: GraphM m gr => m (gr a b) -> Node -> [LEdge b]+out :: (GraphM m gr) => m (gr a b) -> Node -> [LEdge b] out g v = map (\(l,w)->(v,w,l)) (context4 g v) -inn :: GraphM m gr => m (gr a b) -> Node -> [LEdge b]+inn :: (GraphM m gr) => m (gr a b) -> Node -> [LEdge b] inn g v = map (\(l,w)->(w,v,l)) (context1 g v) -outdeg :: GraphM m gr => m (gr a b) -> Node -> Int+outdeg :: (GraphM m gr) => m (gr a b) -> Node -> Int outdeg = length .: context4 -indeg :: GraphM m gr => m (gr a b) -> Node -> Int+indeg :: (GraphM m gr) => m (gr a b) -> Node -> Int indeg  = length .: context1 -deg :: GraphM m gr => m (gr a b) -> Node -> Int+deg :: (GraphM m gr) => m (gr a b) -> Node -> Int deg = (\(p,_,_,s) -> length p+length s) .: context -- @@ -206,7 +223,7 @@  -- graph equality ---nodeComp :: Eq b => LNode b -> LNode b -> Ordering+nodeComp :: (Eq b) => LNode b -> LNode b -> Ordering nodeComp n@(v,a) n'@(w,b) | n == n'   = EQ                           | v<w       = LT                           | otherwise = GT@@ -214,7 +231,7 @@ slabNodes :: (Eq a,Graph gr) => m (gr a b) -> [LNode a] slabNodes = sortBy nodeComp . labNodes -edgeComp :: Eq b => LEdge b -> LEdge b -> Ordering+edgeComp :: (Eq b) => LEdge b -> LEdge b -> Ordering edgeComp e@(v,w,a) e'@(x,y,b) | e == e'              = EQ                               | v<x || (v==x && w<y) = LT                               | otherwise            = GT

@@ -24,7 +24,8 @@     insMapEdgesM, delMapNodesM, delMapEdgesM ) where -import           Control.Monad.State+import           Control.DeepSeq            (NFData (..))+import           Control.Monad.Trans.State import           Data.Graph.Inductive.Graph import           Prelude                    hiding (map) import qualified Prelude                    as P (map)@@ -35,10 +36,13 @@ data NodeMap a =     NodeMap { map :: Map a Node,               key :: Int }-    deriving Show+    deriving (Eq, Show, Read) +instance (NFData a) => NFData (NodeMap a) where+  rnf (NodeMap mp k) = rnf mp `seq` rnf k+ -- | Create a new, empty mapping.-new :: (Ord a) => NodeMap a+new :: NodeMap a new = NodeMap { map = M.empty, key = 0 }  -- LNode = (Node, a)@@ -74,7 +78,7 @@  -- | Generates a list of 'LEdge's. mkEdges :: (Ord a) => NodeMap a -> [(a, a, b)] -> Maybe [LEdge b]-mkEdges m es = mapM (mkEdge m) es+mkEdges m = mapM (mkEdge m)  -- | Construct a list of nodes. mkNodes :: (Ord a) => NodeMap a -> [a] -> ([LNode a], NodeMap a)@@ -174,14 +178,14 @@     do (m, g) <- get        return $ f m -}-liftN2 :: (Ord a, DynGraph g) => (NodeMap a -> c -> (d, NodeMap a)) -> c -> NodeMapM a b g d+liftN2 :: (NodeMap a -> c -> (d, NodeMap a)) -> c -> NodeMapM a b g d liftN2 f c =     do (m, g) <- get        let (r, m') = f m c        put (m', g)        return r -liftN2' :: (Ord a, DynGraph g) => (NodeMap a -> c -> d) -> c -> NodeMapM a b g d+liftN2' :: (NodeMap a -> c -> d) -> c -> NodeMapM a b g d liftN2' f c =     do (m, _) <- get        return $ f m c@@ -198,13 +202,13 @@     do (m, g) <- get        return $ f m c d -}-liftM1 :: (Ord a, DynGraph g) => (NodeMap a -> c -> g a b -> g a b) -> c -> NodeMapM a b g ()+liftM1 :: (NodeMap a -> c -> g a b -> g a b) -> c -> NodeMapM a b g () liftM1 f c =     do (m, g) <- get        let g' = f m c g        put (m, g') -liftM1' :: (Ord a, DynGraph g) => (NodeMap a -> c -> g a b -> (g a b, NodeMap a, d)) -> c -> NodeMapM a b g d+liftM1' :: (NodeMap a -> c -> g a b -> (g a b, NodeMap a, d)) -> c -> NodeMapM a b g d liftM1' f c =     do (m, g) <- get        let (g', m', r) = f m c g

@@ -1,4 +1,7 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif  -- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph' -- using big-endian patricia tree (i.e. "Data.IntMap").@@ -22,25 +25,41 @@     )     where -import           Control.Arrow              (second)-import           Data.Graph.Inductive.Graph-import           Data.IntMap                (IntMap)-import qualified Data.IntMap                as IM-import           Data.List-import           Data.Maybe+import Data.Graph.Inductive.Graph +import           Control.Applicative (liftA2)+import           Control.Arrow       (second)+import           Control.DeepSeq     (NFData (..))+import           Data.IntMap         (IntMap)+import qualified Data.IntMap         as IM+import           Data.List           (sort)+import           Data.Maybe          (fromMaybe)+#if __GLASGOW_HASKELL__ >= 702+import           GHC.Generics        (Generic)+#endif +----------------------------------------------------------------------+-- GRAPH REPRESENTATION+----------------------------------------------------------------------+ newtype Gr a b = Gr (GraphRep a b)+#if __GLASGOW_HASKELL__ >= 702+  deriving (Generic)+#endif  type GraphRep a b = IntMap (Context' a b) type Context' a b = (IntMap [b], a, IntMap [b])  type UGr = Gr () () +----------------------------------------------------------------------+-- CLASS INSTANCES+----------------------------------------------------------------------+ instance (Eq a, Ord b) => Eq (Gr a b) where   (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2     where-      sortAdj (a1,n,a2) = (fmap sort a1,n,fmap sort a2)+      sortAdj (p,n,s) = (fmap sort p,n,fmap sort s)  instance (Show a, Show b) => Show (Gr a b) where   showsPrec d g = showParen (d > 10) $@@ -57,39 +76,43 @@     return (mkGraph ns es, u)  instance Graph Gr where-    -- required members     empty           = Gr IM.empty+     isEmpty (Gr g)  = IM.null g+     match           = matchGr-    mkGraph vs es   = (insEdges' . insNodes vs) empty-        where-          insEdges' g = foldl' (flip insEdge) g es +    mkGraph vs es   = insEdges es+                      . Gr+                      . IM.fromList+                      . map (second (\l -> (IM.empty,l,IM.empty)))+                      $ vs+     labNodes (Gr g) = [ (node, label)                             | (node, (_, label, _)) <- IM.toList g ] -    -- overriding members for efficiency     noNodes   (Gr g) = IM.size g-    nodeRange (Gr g)-        | IM.null g = (0, 0)-        | otherwise = (ix (IM.minViewWithKey g), ix (IM.maxViewWithKey g))-                  where-                    ix = fst . fst . fromJust +    nodeRange (Gr g) = fromMaybe (error "nodeRange of empty graph")+                       $ liftA2 (,) (ix (IM.minViewWithKey g))+                                    (ix (IM.maxViewWithKey g))+      where+        ix = fmap (fst . fst)+     labEdges (Gr g) = do (node, (_, _, s)) <- IM.toList g                          (next, labels)    <- IM.toList s                          label             <- labels                          return (node, next, label) - instance DynGraph Gr where     (p, v, l, s) & (Gr g)         = let !g1 = IM.insert v (fromAdj p, l, fromAdj s) g               !g2 = addSucc g1 v p               !g3 = addPred g2 v s-          in-            Gr g3+          in Gr g3 +instance (NFData a, NFData b) => NFData (Gr a b) where+  rnf (Gr g) = rnf g  matchGr :: Node -> Gr a b -> Decomp Gr a b matchGr node (Gr g)@@ -103,86 +126,80 @@                    !s' = IM.delete node s                    !g2 = clearPred g1 node (IM.keys s')                    !g3 = clearSucc g2 node (IM.keys p')-               in-                 (Just (toAdj p', node, label, toAdj s), Gr g3)+               in (Just (toAdj p', node, label, toAdj s), Gr g3) +----------------------------------------------------------------------+-- OVERRIDING FUNCTIONS+----------------------------------------------------------------------  {-# RULES       "insNode/Data.Graph.Inductive.PatriciaTree"  insNode = fastInsNode   #-} fastInsNode :: LNode a -> Gr a b -> Gr a b fastInsNode (v, l) (Gr g) = g' `seq` Gr g'-    where-      g' = IM.insert v (IM.empty, l, IM.empty) g-+  where+    g' = IM.insert v (IM.empty, l, IM.empty) g  {-# RULES       "insEdge/Data.Graph.Inductive.PatriciaTree"  insEdge = fastInsEdge   #-} fastInsEdge :: LEdge b -> Gr a b -> Gr a b fastInsEdge (v, w, l) (Gr g) = g2 `seq` Gr g2-    where-      g1 = IM.adjust addSucc' v g-      g2 = IM.adjust addPred' w g1--      addSucc' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss)-      addPred' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)+  where+    g1 = IM.adjust addSucc' v g+    g2 = IM.adjust addPred' w g1 +    addSucc' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss)+    addPred' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)  {-# RULES       "gmap/Data.Graph.Inductive.PatriciaTree"  gmap = fastGMap   #-} fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d fastGMap f (Gr g) = Gr (IM.mapWithKey f' g)-    where-      f' :: Node -> Context' a b -> Context' c d-      f' = ((fromContext . f) .) . toContext-+  where+    f' :: Node -> Context' a b -> Context' c d+    f' = ((fromContext . f) .) . toContext  {-# RULES       "nmap/Data.Graph.Inductive.PatriciaTree"  nmap = fastNMap   #-} fastNMap :: forall a b c. (a -> c) -> Gr a b -> Gr c b fastNMap f (Gr g) = Gr (IM.map f' g)-    where-      f' :: Context' a b -> Context' c b-      f' (ps, a, ss) = (ps, f a, ss)-+  where+    f' :: Context' a b -> Context' c b+    f' (ps, a, ss) = (ps, f a, ss)  {-# RULES       "emap/Data.Graph.Inductive.PatriciaTree"  emap = fastEMap   #-} fastEMap :: forall a b c. (b -> c) -> Gr a b -> Gr a c fastEMap f (Gr g) = Gr (IM.map f' g)-    where-      f' :: Context' a b -> Context' a c-      f' (ps, a, ss) = (IM.map (map f) ps, a, IM.map (map f) ss)+  where+    f' :: Context' a b -> Context' a c+    f' (ps, a, ss) = (IM.map (map f) ps, a, IM.map (map f) ss) +----------------------------------------------------------------------+-- UTILITIES+----------------------------------------------------------------------  toAdj :: IntMap [b] -> Adj b toAdj = concatMap expand . IM.toList   where     expand (n,ls) = map (flip (,) n) ls - fromAdj :: Adj b -> IntMap [b]-fromAdj = IM.fromListWith addLists . map (second return . swap)-+fromAdj = IM.fromListWith addLists . map (second (:[]) . swap)  toContext :: Node -> Context' a b -> Context a b-toContext v (ps, a, ss)-    = (toAdj ps, v, a, toAdj ss)-+toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss)  fromContext :: Context a b -> Context' a b-fromContext (ps, _, a, ss)-    = (fromAdj ps, a, fromAdj ss)-+fromContext (ps, _, a, ss) = (fromAdj ps, a, fromAdj ss)  swap :: (a, b) -> (b, a) swap (a, b) = (b, a) - -- A version of @++@ where order isn't important, so @xs ++ [x]@ -- becomes @x:xs@.  Used when we have to have a function of type @[a] -- -> [a] -> [a]@ but one of the lists is just going to be a single@@ -203,22 +220,22 @@ addPred :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b addPred g _ []              = g addPred g v ((l, s) : rest) = addPred g' v rest-    where-      g' = IM.adjust f s g-      f (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)+  where+    g' = IM.adjust f s g+    f (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)   clearSucc :: GraphRep a b -> Node -> [Node] -> GraphRep a b clearSucc g _ []       = g clearSucc g v (p:rest) = clearSucc g' v rest-    where-      g' = IM.adjust f p g-      f (ps, l, ss) = (ps, l, IM.delete v ss)+  where+    g' = IM.adjust f p g+    f (ps, l, ss) = (ps, l, IM.delete v ss)   clearPred :: GraphRep a b -> Node -> [Node] -> GraphRep a b clearPred g _ []       = g clearPred g v (s:rest) = clearPred g' v rest-    where-      g' = IM.adjust f s g-      f (ps, l, ss) = (IM.delete v ps, l, ss)+  where+    g' = IM.adjust f s g+    f (ps, l, ss) = (IM.delete v ps, l, ss)

@@ -1,29 +1,15 @@-module Data.Graph.Inductive.Query(-    module Data.Graph.Inductive.Query.DFS,-    module Data.Graph.Inductive.Query.BFS,-    module Data.Graph.Inductive.Query.SP,-    module Data.Graph.Inductive.Query.GVD,-    module Data.Graph.Inductive.Query.MST,-    module Data.Graph.Inductive.Query.Indep,-    module Data.Graph.Inductive.Query.MaxFlow,-    module Data.Graph.Inductive.Query.MaxFlow2,-    module Data.Graph.Inductive.Query.ArtPoint,-    module Data.Graph.Inductive.Query.BCC,-    module Data.Graph.Inductive.Query.Dominators,-    module Data.Graph.Inductive.Query.TransClos,-    module Data.Graph.Inductive.Query.Monad,-) where+module Data.Graph.Inductive.Query (module Q) where -import Data.Graph.Inductive.Query.ArtPoint-import Data.Graph.Inductive.Query.BCC-import Data.Graph.Inductive.Query.BFS-import Data.Graph.Inductive.Query.DFS-import Data.Graph.Inductive.Query.Dominators-import Data.Graph.Inductive.Query.GVD-import Data.Graph.Inductive.Query.Indep-import Data.Graph.Inductive.Query.MaxFlow-import Data.Graph.Inductive.Query.MaxFlow2-import Data.Graph.Inductive.Query.Monad-import Data.Graph.Inductive.Query.MST-import Data.Graph.Inductive.Query.SP-import Data.Graph.Inductive.Query.TransClos+import Data.Graph.Inductive.Query.ArtPoint   as Q+import Data.Graph.Inductive.Query.BCC        as Q+import Data.Graph.Inductive.Query.BFS        as Q+import Data.Graph.Inductive.Query.DFS        as Q+import Data.Graph.Inductive.Query.Dominators as Q+import Data.Graph.Inductive.Query.GVD        as Q+import Data.Graph.Inductive.Query.Indep      as Q+import Data.Graph.Inductive.Query.MaxFlow    as Q+import Data.Graph.Inductive.Query.MaxFlow2   as Q+import Data.Graph.Inductive.Query.Monad      as Q+import Data.Graph.Inductive.Query.MST        as Q+import Data.Graph.Inductive.Query.SP         as Q+import Data.Graph.Inductive.Query.TransClos  as Q

@@ -12,7 +12,7 @@ -- lead to back back edges for that vertex v. ------------------------------------------------------------------------------ data DFSTree a = B (a,a,[(a,a)]) [DFSTree a]-     deriving (Eq)+     deriving (Eq, Show, Read)  ------------------------------------------------------------------------------ -- Tree for storing the DFS and low numbers for each node in the graph.@@ -20,7 +20,7 @@ -- n is its DFS number and l is its low number. ------------------------------------------------------------------------------ data LOWTree a = Brc (a,a,a) [LOWTree a]-     deriving (Eq)+     deriving (Eq, Show, Read)  ------------------------------------------------------------------------------ -- Finds the back edges for a given node.@@ -33,7 +33,7 @@ -- Builds a DFS tree for a given graph. Each element (v,n,b) in the tree -- contains: the node number v, the DFS number n, and a list of backedges b. -------------------------------------------------------------------------------dfsTree :: Graph gr => Int -> Node -> [Node] -> [[(Node,Int)]] ->+dfsTree :: (Graph gr) => Int -> Node -> [Node] -> [[(Node,Int)]] ->                        gr a b -> ([DFSTree Int],gr a b,Int) dfsTree n _ []      _ g             = ([],g,n) dfsTree n _ _       _ g | isEmpty g = ([],g,n)@@ -77,7 +77,7 @@ -- Builds a low tree for a given graph. Each element (v,n,low) in the tree -- contains: the node number v, the DFS number n, and the low number low. -------------------------------------------------------------------------------getLowTree :: Graph gr => gr a b -> Node -> LOWTree Int+getLowTree :: (Graph gr) => gr a b -> Node -> LOWTree Int getLowTree g v = lowTree (head dfsf)                   where (dfsf, _, _) = dfsTree 0 0 [v] [] g @@ -90,7 +90,7 @@ isap :: LOWTree Int -> Bool isap (Brc (_,_,_) []) = False isap (Brc (_,1,_) ts) = length ts > 1-isap (Brc (_,n,_) ts) = length ch >= 1+isap (Brc (_,n,_) ts) = not (null ch)                         where ch = filter ( >=n) (map getLow ts)  ------------------------------------------------------------------------------@@ -105,7 +105,7 @@ ------------------------------------------------------------------------------ -- Finds the articulation points of a graph starting at a given node. -------------------------------------------------------------------------------artpoints :: Graph gr => gr a b -> Node -> [Node]+artpoints :: (Graph gr) => gr a b -> Node -> [Node] artpoints g v = arp (getLowTree g v)  {-|@@ -117,5 +117,5 @@    b) An non-root node v is an articulation point iff there exists at least       one child w of v such that lowNumber(w) >= dfsNumber(v). -}-ap :: Graph gr => gr a b -> [Node]+ap :: (Graph gr) => gr a b -> [Node] ap g = artpoints g v where ((_,v,_,_),_) = matchAny g

@@ -12,15 +12,15 @@ -- Given a graph g, this function computes the subgraphs which are -- g's connected components. -------------------------------------------------------------------------------gComponents :: DynGraph gr => gr a b -> [gr a b]-gComponents g = map (\(x,y)-> mkGraph x y) (zip ln le)-            where ln         = map (\x->[(u,l)|(u,l)<-vs,elem u x]) cc-                  le         = map (\x->[(u,v,l)|(u,v,l)<-es,elem u x]) cc+gComponents :: (DynGraph gr) => gr a b -> [gr a b]+gComponents g = zipWith mkGraph ln le+            where ln         = map (\x->[(u,l)|(u,l)<-vs,u `elem` x]) cc+                  le         = map (\x->[(u,v,l)|(u,v,l)<-es,u `elem` x]) cc                   (vs,es,cc) = (labNodes g,labEdges g,components g)  -embedContexts :: DynGraph gr => Context a b -> [gr a b] -> [gr a b]-embedContexts (_,v,l,s) gs = map (\(x,y)-> x & y) (zip lc gs)+embedContexts :: (DynGraph gr) => Context a b -> [gr a b] -> [gr a b]+embedContexts (_,v,l,s) gs = zipWith (&) lc gs                   where lc = map (\e->(e,v,l,e)) lc'                         lc'= map (\g->[ e | e <- s, gelem (snd e) g]) gs @@ -28,11 +28,11 @@ -- Given a node v and a list of graphs, this function returns the graph which -- v belongs to, together with a list of the remaining graphs. -------------------------------------------------------------------------------findGraph :: DynGraph gr => Node -> [gr a b] -> (Decomp gr a b, [gr a b])+findGraph :: (DynGraph gr) => Node -> [gr a b] -> (Decomp gr a b, [gr a b]) findGraph _ [] = error "findGraph: empty graph list" findGraph v (g:gs) = case match v g of-                          (Nothing,  g) -> let (d, gs') = findGraph v gs-                                           in (d, g : gs')+                          (Nothing,  g') -> let (d, gs') = findGraph v gs+                                            in (d, g' : gs')                           (Just c,  g') -> ((Just c, g'), gs)  ------------------------------------------------------------------------------@@ -40,7 +40,7 @@ -- for each articulation point and returns the connected components of the -- resulting disconnected graph. -------------------------------------------------------------------------------splitGraphs :: DynGraph gr => [gr a b] -> [Node] -> [gr a b]+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@@ -53,5 +53,5 @@ It first finds the articulation points of the graph. Then it disconnects the graph on each articulation point and computes the connected components. -}-bcc :: DynGraph gr => gr a b -> [gr a b]+bcc :: (DynGraph gr) => gr a b -> [gr a b] bcc g = splitGraphs [g] (ap g)

@@ -2,16 +2,22 @@ -- | Breadth-First Search Algorithms  module Data.Graph.Inductive.Query.BFS(+     -- * BFS Node List-    bfs,bfsn,bfsWith,bfsnWith,+    bfs, bfsn, bfsWith, bfsnWith,+     -- * Node List With Depth Info-    level,leveln,+    level, leveln,+     -- * BFS Edges-    bfe,bfen,+    bfe, bfen,+     -- * BFS Tree-    bft,lbft,+    bft, lbft, RTree,+     -- * Shortest Path (Number of Edges)-    esp,lesp+    esp, lesp+ ) where  @@ -21,7 +27,7 @@  -- bfs (node list ordered by distance) ---bfsnInternal :: Graph gr => (Context a b -> c) -> Queue Node -> gr a b -> [c]+bfsnInternal :: (Graph gr) => (Context a b -> c) -> Queue Node -> gr a b -> [c] bfsnInternal f q g | queueEmpty q || isEmpty g = []                    | otherwise                 =        case match v g of@@ -29,27 +35,28 @@         (Nothing, g') -> bfsnInternal f q' g'         where (v,q') = queueGet q -bfsnWith :: Graph gr => (Context a b -> c) -> [Node] -> gr a b -> [c]+bfsnWith :: (Graph gr) => (Context a b -> c) -> [Node] -> gr a b -> [c] bfsnWith f vs = bfsnInternal f (queuePutList vs mkQueue) -bfsn :: Graph gr => [Node] -> gr a b -> [Node]+bfsn :: (Graph gr) => [Node] -> gr a b -> [Node] bfsn = bfsnWith node' -bfsWith :: Graph gr => (Context a b -> c) -> Node -> gr a b -> [c]+bfsWith :: (Graph gr) => (Context a b -> c) -> Node -> gr a b -> [c] bfsWith f v = bfsnInternal f (queuePut v mkQueue) -bfs :: Graph gr => Node -> gr a b -> [Node]+bfs :: (Graph gr) => Node -> gr a b -> [Node] bfs = bfsWith node'   -- level (extension of bfs giving the depth of each node) ---level :: Graph gr => Node -> gr a b -> [(Node,Int)]+level :: (Graph gr) => Node -> gr a b -> [(Node,Int)] level v = leveln [(v,0)] +suci :: Context a b -> Int -> [(Node, Int)] suci c i = zip (suc' c) (repeat i) -leveln :: Graph gr => [(Node,Int)] -> gr a b -> [(Node,Int)]+leveln :: (Graph gr) => [(Node,Int)] -> gr a b -> [(Node,Int)] leveln []         _             = [] leveln _          g | isEmpty g = [] leveln ((v,j):vs) g = case match v g of@@ -60,7 +67,7 @@ -- bfe (breadth first edges) -- remembers predecessor information ---bfenInternal :: Graph gr => Queue Edge -> gr a b -> [Edge]+bfenInternal :: (Graph gr) => Queue Edge -> gr a b -> [Edge] bfenInternal q g | queueEmpty q || isEmpty g = []                  | otherwise                 =       case match v g of@@ -68,13 +75,14 @@         (Nothing, g') -> bfenInternal q' g'         where ((u,v),q') = queueGet q -bfen :: Graph gr => [Edge] -> gr a b -> [Edge]-bfen vs g = bfenInternal (queuePutList vs mkQueue) g+bfen :: (Graph gr) => [Edge] -> gr a b -> [Edge]+bfen vs = bfenInternal (queuePutList vs mkQueue) -bfe :: Graph gr => Node -> gr a b -> [Edge]+bfe :: (Graph gr) => Node -> gr a b -> [Edge] bfe v = bfen [(v,v)] -outU c = map (\(v,w,_)->(v,w)) (out' c)+outU :: Context a b -> [Edge]+outU c = map toEdge (out' c)   -- bft (breadth first search tree)@@ -93,10 +101,10 @@ -- faster shortest paths -- here: with root path trees ---bft :: Graph gr => Node -> gr a b -> RTree+bft :: (Graph gr) => Node -> gr a b -> RTree bft v = bf (queuePut [v] mkQueue) -bf :: Graph gr => Queue Path -> gr a b -> RTree+bf :: (Graph gr) => Queue Path -> gr a b -> RTree bf q g | queueEmpty q || isEmpty g = []        | otherwise                 =        case match v g of@@ -104,7 +112,7 @@          (Nothing, g') -> bf q' g'          where (p@(v:_),q') = queueGet q -esp :: Graph gr => Node -> Node -> gr a b -> Path+esp :: (Graph gr) => Node -> Node -> gr a b -> Path esp s t = getPath t . bft s  @@ -112,19 +120,19 @@ -- Note that the label of the first node in a returned path is meaningless; -- all other nodes are paired with the label of their incoming edge. ---lbft :: Graph gr => Node -> gr a b -> LRTree b-lbft v g = case (out g v) of+lbft :: (Graph gr) => Node -> gr a b -> LRTree b+lbft v g = case out g v of              []         -> [LP []]              (v',_,l):_ -> lbf (queuePut (LP [(v',l)]) mkQueue) g -lbf :: Graph gr => Queue (LPath b) -> gr a b -> LRTree b+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+         where (LP (p@((v,_):_)),q') = queueGet q -lesp :: Graph gr => Node -> Node -> gr a b -> LPath b+lesp :: (Graph gr) => Node -> Node -> gr a b -> LPath b lesp s t = getLPath t . lbft s

@@ -1,108 +1,84 @@ -- (c) 2000 - 2005 by Martin Erwig [see file COPYRIGHT]--- | Depth-First Search -module Data.Graph.Inductive.Query.DFS(+-- | Depth-first search algorithms.+--+-- Names consist of:+--+--   1. An optional direction parameter, specifying which nodes to visit next.+--+--      [@x@] undirectional: ignore edge direction+--      [@r@] reversed: walk edges in reverse+--      [@x@] user defined: speciy which paths to follow+--+--   2. "df" for depth-first+--   3. A structure parameter, specifying the type of the result.+--+--       [@s@] Flat list of results+--       [@f@] Structured 'Tree' of results+--+--   4. An optional \"With\", which instead of putting the found nodes directly+--      into the result, adds the result of a computation on them into it.+--   5. An optional prime character, in which case all nodes of the graph will+--      be visited, instead of a user-given subset.+module Data.Graph.Inductive.Query.DFS (+     CFun,-    dfs,dfs',dff,dff',-    dfsWith, dfsWith',dffWith,dffWith',-    xdfsWith,xdfWith,xdffWith,-    -- * Undirected DFS-    udfs,udfs',udff,udff',-    udffWith,udffWith',-    -- * Reverse DFS-    rdff,rdff',rdfs,rdfs',-    rdffWith,rdffWith',-    -- * Applications of DFS\/DFF-    topsort,topsort',scc,reachable,-    -- * Applications of UDFS\/UDFF-    components,noComponents,isConnected-) where -import Data.Graph.Inductive.Basic-import Data.Graph.Inductive.Graph-import Data.Tree+    -- * Standard+    dfs, dfs', dff, dff',+    dfsWith,  dfsWith', dffWith, dffWith',+    xdfsWith, xdfWith, xdffWith, -------------------------------------------------------------------------- DFS AND FRIENDS-----------------------------------------------------------------------+    -- * Undirected+    udfs, udfs', udff, udff',+    udffWith, udffWith', -{-+    -- * Reversed+    rdff, rdff', rdfs, rdfs',+    rdffWith, rdffWith', -  Classification of all 32 dfs functions:+    -- * Applications of depth first search/forest+    topsort, topsort', scc, reachable, -    dfs-function ::= [direction]"df"structure["With"]["'"]-    direction  -->  "x" | "u" | "r"-    structure  -->  "s" | "f"+    -- * Applications of undirected depth first search/forest+    components, noComponents, isConnected, condensation -              |   structure-   direction  |   "s"   "f"-   ------------------------   + optional With + optional '-      "x"     | xdfs  xdff-      " "     |  dfs   dff-      "u"     | udfs  udff-      "r"     | rdfs  rdff-   ------------------------+) where -  Direction Parameter-  --------------------   x : parameterized by a function that specifies which nodes-       to be visited next+import Data.Graph.Inductive.Basic+import Data.Graph.Inductive.Graph+import Data.Tree+import qualified Data.Map as Map+import Control.Monad (liftM2) -  " ": the "normal case: just follow successors -   u : undirected, ie, follow predecesors and successors -   r : reverse, ie, follow predecesors---  Structure Parameter-  --------------------   s : result is a list of-        (a) objects computed from visited contexts  ("With"-version)-        (b) nodes                                   (normal version)--   f : result is a tree/forest of-        (a) objects computed from visited contexts  ("With"-version)-        (b) nodes                                   (normal version)--  Optional Suffixes-  ------------------   With : objects to be put into list/tree are given by a function-          on contexts, default for non-"With" versions: nodes--   '    : parameter node list is given implicitly by the nodes of the-          graph to be traversed, default for non-"'" versions: nodes-          must be provided explicitly---  Defined are only the following 22 most frabjuous function versions:--    xdfsWith-     dfsWith,dfsWith',dfs,dfs'-     udfs,udfs'-     rdfs,rdfs'-    xdffWith-     dffWith,dffWith',dff,dff'-     udffWith,udffWith',udff,udff'-     rdffWith,rdffWith',rdff,rdff'--  Others can be added quite easily if needed.---}---- fixNodes fixes the nodes of the graph as a parameter----fixNodes :: Graph gr => ([Node] -> gr a b -> c) -> gr a b -> c+-- | Many functions take a list of nodes to visit as an explicit argument.+--   fixNodes is a convenience function that adds all the nodes present in a+--   graph as that list.+fixNodes :: (Graph gr) => ([Node] -> gr a b -> c) -> gr a b -> c fixNodes f g = f (nodes g) g  --- generalized depth-first search---  (could also be simply defined as applying preorderF to the---   result of xdffWith)--- type CFun a b c = Context a b -> c -xdfsWith :: Graph gr => CFun a b [Node] -> CFun a b c -> [Node] -> gr a b -> [c]+-- | Most general DFS algorithm to create a list of results. The other+--   list-returning functions such as 'dfs' are all defined in terms of this+--   one.+--+-- @+-- 'xdfsWith' d f vs = 'preorderF' . 'xdffWith' d f vs+-- @+xdfsWith :: (Graph gr)+    => CFun a b [Node] -- ^ Mapping from a node to its neighbours to be visited+                       --   as well. 'suc'' for example makes 'xdfsWith'+                       --   traverse the graph following the edge directions,+                       --   while 'pre'' means reversed directions.+    -> CFun a b c      -- ^ Mapping from the 'Context' of a node to a result+                       --   value.+    -> [Node]          -- ^ Nodes to be visited.+    -> gr a b+    -> [c] xdfsWith _ _ []     _             = [] xdfsWith _ _ _      g | isEmpty g = [] xdfsWith d f (v:vs) g = case match v g of@@ -110,42 +86,46 @@                          (Nothing,g') -> xdfsWith d f vs g'  --- dfs----dfsWith :: Graph gr => CFun a b c -> [Node] -> gr a b -> [c]+-- | Depth-first search.+dfs :: (Graph gr) => [Node] -> gr a b -> [Node]+dfs = dfsWith node'++dfsWith :: (Graph gr) => CFun a b c -> [Node] -> gr a b -> [c] dfsWith = xdfsWith suc' -dfsWith' :: Graph gr => CFun a b c -> gr a b -> [c]+dfsWith' :: (Graph gr) => CFun a b c -> gr a b -> [c] dfsWith' f = fixNodes (dfsWith f) -dfs :: Graph gr => [Node] -> gr a b -> [Node]-dfs = dfsWith node'--dfs' :: Graph gr => gr a b -> [Node]+dfs' :: (Graph gr) => gr a b -> [Node] dfs' = dfsWith' node'  --- undirected dfs, ie, ignore edge directions----udfs :: Graph gr => [Node] -> gr a b -> [Node]+-- | Undirected depth-first search, obtained by following edges regardless+--   of their direction.+udfs :: (Graph gr) => [Node] -> gr a b -> [Node] udfs = xdfsWith neighbors' node' -udfs' :: Graph gr => gr a b -> [Node]+udfs' :: (Graph gr) => gr a b -> [Node] udfs' = fixNodes udfs  --- reverse dfs, ie, follow predecessors----rdfs :: Graph gr => [Node] -> gr a b -> [Node]+-- | Reverse depth-first search, obtained by following predecessors.+rdfs :: (Graph gr) => [Node] -> gr a b -> [Node] rdfs = xdfsWith pre' node' -rdfs' :: Graph gr => gr a b -> [Node]+rdfs' :: (Graph gr) => gr a b -> [Node] rdfs' = fixNodes rdfs  --- generalized depth-first forest----xdfWith :: Graph gr => CFun a b [Node] -> CFun a b c -> [Node] -> gr a b -> ([Tree c],gr a b)+-- | Most general DFS algorithm to create a forest of results, otherwise very+--   similar to 'xdfsWith'. The other forest-returning functions such as 'dff'+--   are all defined in terms of this one.+xdfWith :: (Graph gr)+    => CFun a b [Node]+    -> CFun a b c+    -> [Node]+    -> gr a b+    -> ([Tree c],gr a b) xdfWith _ _ []     g             = ([],g) xdfWith _ _ _      g | isEmpty g = ([],g) xdfWith d f (v:vs) g = case match v g of@@ -154,52 +134,62 @@                                  where (ts,g2)  = xdfWith d f (d c) g1                                        (ts',g3) = xdfWith d f vs g2 -xdffWith :: Graph gr => CFun a b [Node] -> CFun a b c -> [Node] -> gr a b -> [Tree c]+-- | Discard the graph part of the result of 'xdfWith'.+--+-- @+-- xdffWith d f vs g = fst (xdfWith d f vs g)+-- @+xdffWith :: (Graph gr)+    => CFun a b [Node]+    -> CFun a b c+    -> [Node]+    -> gr a b+    -> [Tree c] xdffWith d f vs g = fst (xdfWith d f vs g)  --- dff----dffWith :: Graph gr => CFun a b c -> [Node] -> gr a b -> [Tree c]++-- | Directed depth-first forest.+dff :: (Graph gr) => [Node] -> gr a b -> [Tree Node]+dff = dffWith node'++dffWith :: (Graph gr) => CFun a b c -> [Node] -> gr a b -> [Tree c] dffWith = xdffWith suc' -dffWith' :: Graph gr => CFun a b c -> gr a b -> [Tree c]+dffWith' :: (Graph gr) => CFun a b c -> gr a b -> [Tree c] dffWith' f = fixNodes (dffWith f) -dff :: Graph gr => [Node] -> gr a b -> [Tree Node]-dff = dffWith node'--dff' :: Graph gr => gr a b -> [Tree Node]+dff' :: (Graph gr) => gr a b -> [Tree Node] dff' = dffWith' node'  --- undirected dff----udffWith :: Graph gr => CFun a b c -> [Node] -> gr a b -> [Tree c]++-- | Undirected depth-first forest, obtained by following edges regardless+--   of their direction.+udff :: (Graph gr) => [Node] -> gr a b -> [Tree Node]+udff = udffWith node'++udffWith :: (Graph gr) => CFun a b c -> [Node] -> gr a b -> [Tree c] udffWith = xdffWith neighbors' -udffWith' :: Graph gr => CFun a b c -> gr a b -> [Tree c]+udffWith' :: (Graph gr) => CFun a b c -> gr a b -> [Tree c] udffWith' f = fixNodes (udffWith f) -udff :: Graph gr => [Node] -> gr a b -> [Tree Node]-udff = udffWith node'--udff' :: Graph gr => gr a b -> [Tree Node]+udff' :: (Graph gr) => gr a b -> [Tree Node] udff' = udffWith' node'  --- reverse dff, ie, following predecessors----rdffWith :: Graph gr => CFun a b c -> [Node] -> gr a b -> [Tree c]+-- | Reverse depth-first forest, obtained by following predecessors.+rdff :: (Graph gr) => [Node] -> gr a b -> [Tree Node]+rdff = rdffWith node'++rdffWith :: (Graph gr) => CFun a b c -> [Node] -> gr a b -> [Tree c] rdffWith = xdffWith pre' -rdffWith' :: Graph gr => CFun a b c -> gr a b -> [Tree c]+rdffWith' :: (Graph gr) => CFun a b c -> gr a b -> [Tree c] rdffWith' f = fixNodes (rdffWith f) -rdff :: Graph gr => [Node] -> gr a b -> [Tree Node]-rdff = rdffWith node'--rdff' :: Graph gr => gr a b -> [Tree Node]+rdff' :: (Graph gr) => gr a b -> [Tree Node] rdff' = rdffWith' node'  @@ -207,30 +197,55 @@ -- ALGORITHMS BASED ON DFS ---------------------------------------------------------------------- -components :: Graph gr => gr a b -> [[Node]]-components = (map preorder) . udff'+-- | Collection of connected components+components :: (Graph gr) => gr a b -> [[Node]]+components = map preorder . udff' -noComponents :: Graph gr => gr a b -> Int+-- | Number of connected components+noComponents :: (Graph gr) => gr a b -> Int noComponents = length . components -isConnected :: Graph gr => gr a b -> Bool+-- | Is the graph connected?+isConnected :: (Graph gr) => gr a b -> Bool isConnected = (==1) . noComponents +-- | Flatten a 'Tree' in reverse order postflatten :: Tree a -> [a] postflatten (Node v ts) = postflattenF ts ++ [v] +-- | Flatten a forest in reverse order postflattenF :: [Tree a] -> [a] postflattenF = concatMap postflatten -topsort :: Graph gr => gr a b -> [Node]+-- | <http://en.wikipedia.org/wiki/Topological_sorting Topological sorting>,+--   i.e. a list of 'Node's so that if there's an edge between a source and a+--   target node, the source appears earlier in the result.+topsort :: (Graph gr) => gr a b -> [Node] topsort = reverse . postflattenF . dff' -topsort' :: Graph gr => gr a b -> [a]-topsort' = reverse . postorderF . (dffWith' lab')+-- | 'topsort', returning only the labels of the nodes.+topsort' :: (Graph gr) => gr a b -> [a]+topsort' = reverse . postorderF . dffWith' lab' -scc :: Graph gr => gr a b -> [[Node]]-scc g = map preorder (rdff (topsort g) g)            -- optimized, using rdff--- sccOrig g = map preorder (dff (topsort g) (grev g))  -- original by Sharir+-- | Collection of strongly connected components+scc :: (Graph gr) => gr a b -> [[Node]]+scc g = map preorder (rdff (topsort g) g) -reachable :: Graph gr => Node -> gr a b -> [Node]+-- | Collection of nodes reachable from a starting point.+reachable :: (Graph gr) => Node -> gr a b -> [Node] reachable v g = preorderF (dff [v] g)++-- | The condensation of the given graph, i.e., the graph of its+-- strongly connected components.+condensation :: Graph gr => gr a b -> gr [Node] ()+condensation gr = mkGraph vs es+  where+    sccs = scc gr+    vs = zip [1..] sccs+    vMap = Map.fromList $ map swap vs++    swap = uncurry $ flip (,)++    getN = (vMap Map.!)+    es = [ (getN c1, getN c2, ()) | c1 <- sccs, c2 <- sccs+                                  , (c1 /= c2) && any (hasEdge gr) (liftM2 (,) c1 c2) ]

@@ -20,16 +20,17 @@ 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-iDom :: Graph gr => gr a b -> Node -> [(Node,Node)]+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-dom :: Graph gr => gr a b -> Node -> [(Node,[Node])]+dom :: (Graph gr) => gr a b -> Node -> [(Node,[Node])] dom g root = let-    (iDom, toNode, fromNode) = idomWork g root-    dom' = getDom toNode iDom+    (iD, toNode, fromNode) = idomWork g root+    dom' = getDom toNode iD     nodes' = nodes g     rest = I.keys (I.filter (-1 ==) fromNode)   in@@ -48,14 +49,14 @@ type ToNode = Array Node' Node type FromNode = IntMap Node' -idomWork :: Graph gr => gr a b -> Node -> (IDom, ToNode, FromNode)+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-    iDom0 = array (1, s-1) (tail $ treeEdges (-1) ntree)+    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@@ -63,29 +64,29 @@     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.-    iDom = fixEq (refineIDom preds) iDom0+    iD = fixEq (refineIDom preds) iD0   in     if null trees then error "Dominators.idomWork: root not in graph"-                  else (iDom, toNode, fromNode)+                  else (iD, toNode, fromNode)  -- for each node in iDom, find the intersection of all its predecessor's -- dominating sets, and update iDom accordingly. refineIDom :: Preds -> IDom -> IDom-refineIDom preds iDom = fmap (foldl1 (intersect iDom)) preds+refineIDom preds iD = fmap (foldl1 (intersect iD)) preds  -- find the intersection of the two given dominance sets. intersect :: IDom -> Node' -> Node' -> Node'-intersect iDom a b = case a `compare` b of-    LT -> intersect iDom a (iDom ! b)+intersect iD a b = case a `compare` b of+    LT -> intersect iD a (iD ! b)     EQ -> a-    GT -> intersect iDom (iDom ! a) b+    GT -> intersect iD (iD ! a) b  -- convert an IDom to dominance sets. we translate to graph nodes here -- because mapping later would be more expensive and lose sharing. getDom :: ToNode -> IDom -> Array Node' [Node]-getDom toNode iDom = let-    res = array (0, snd (bounds iDom)) ((0, [toNode ! 0]) :-          [(i, toNode ! i : res ! (iDom ! i)) | i <- range (bounds iDom)])+getDom toNode iD = let+    res = array (0, snd (bounds iD)) ((0, [toNode ! 0]) :+          [(i, toNode ! i : res ! (iD ! i)) | i <- range (bounds iD)])   in     res @@ -106,7 +107,7 @@ treeEdges a (Node b ts) = (b,a) : concatMap (treeEdges b) ts  -- find a fixed point of f, iteratively-fixEq :: Eq a => (a -> a) -> a -> a+fixEq :: (Eq a) => (a -> a) -> a -> a fixEq f v | v' == v   = v           | otherwise = fixEq f v'     where v' = f v

@@ -1,8 +1,10 @@ -- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT] -- | Graph Voronoi Diagram-+--+--   These functions can be used to create a /shortest path forest/+--   where the roots are specified. module Data.Graph.Inductive.Query.GVD (-    Voronoi,+    Voronoi,LRTree,     gvdIn,gvdOut,     voronoiSet,nearestNode,nearestDist,nearestPath, --    vd,nn,ns,@@ -19,28 +21,47 @@ import Data.Graph.Inductive.Internal.RootPath import Data.Graph.Inductive.Query.SP          (dijkstra) +-- | Representation of a shortest path forest. type Voronoi a = LRTree a +-- | Produce a shortest path forest (the roots of which are those+--   nodes specified) from nodes in the graph /to/ one of the root+--   nodes (if possible). gvdIn :: (DynGraph gr, Real b) => [Node] -> gr a b -> Voronoi b gvdIn vs g = gvdOut vs (grev g) +-- | Produce a shortest path forest (the roots of which are those+--   nodes specified) from nodes in the graph /from/ one of the root+--   nodes (if possible). gvdOut :: (Graph gr, Real b) => [Node] -> gr a b -> Voronoi b gvdOut vs = dijkstra (H.build (zip (repeat 0) (map (\v->LP [(v,0)]) vs))) -voronoiSet :: Real b => Node -> Voronoi b -> [Node]-voronoiSet v = nub . concat . filter (\p->last p==v) . map (\(LP p)->map fst p)+-- | Return the nodes reachable to/from (depending on how the+--   'Voronoi' was constructed) from the specified root node (if the+--   specified node is not one of the root nodes of the shortest path+--   forest, an empty list will be returned).+voronoiSet :: Node -> Voronoi b -> [Node]+voronoiSet v = nub . concat . filter (\p->last p==v) . map (map fst . unLPath) -maybePath :: Real b => Node -> Voronoi b -> Maybe (LPath b)-maybePath v = listToMaybe . filter (\(LP ((w,_):_))->w==v)+-- | Try to construct a path to/from a specified node to one of the+--   root nodes of the shortest path forest.+maybePath :: Node -> Voronoi b -> Maybe (LPath b)+maybePath v = listToMaybe . filter ((v==) . fst . head . unLPath) -nearestNode :: Real b => Node -> Voronoi b -> Maybe Node-nearestNode v = fmap (\(LP ((w,_):_))->w) . maybePath v+-- | Try to determine the nearest root node to the one specified in the+--   shortest path forest.+nearestNode :: (Real b) => Node -> Voronoi b -> Maybe Node+nearestNode v = fmap (fst . last . unLPath) . maybePath v -nearestDist :: Real b => Node -> Voronoi b -> Maybe b-nearestDist v = fmap (\(LP ((_,l):_))->l) . maybePath v+-- | The distance to the 'nearestNode' (if there is one) in the+--   shortest path forest.+nearestDist :: Node -> Voronoi b -> Maybe b+nearestDist v = fmap (snd . head . unLPath) . maybePath v -nearestPath :: Real b => Node -> Voronoi b -> Maybe Path-nearestPath v = fmap (\(LP p)->map fst p) . maybePath v+-- | Try to construct a path to/from a specified node to one of the+--   root nodes of the shortest path forest.+nearestPath :: Node -> Voronoi b -> Maybe Path+nearestPath v = fmap (map fst . unLPath) . maybePath v   -- vd = gvdIn [4,5] vor

@@ -1,23 +1,33 @@ -- (c) 2000 - 2002 by Martin Erwig [see file COPYRIGHT] -- | Maximum Independent Node Sets- module Data.Graph.Inductive.Query.Indep (     indep-) where-+  , indepSize+  ) where  import Data.Graph.Inductive.Graph +import Control.Arrow ((***))+import Data.Function (on)+import Data.List     (maximumBy) -first :: (a -> Bool) -> [a] -> a-first p = head . filter p+-- ----------------------------------------------------------------------------- -indep :: DynGraph gr => gr a b -> [Node]-indep g | isEmpty g = []-indep g = if length i1>length i2 then i1 else i2-          where vs          = nodes g-                m           = maximum (map (deg g) vs)-                v           = first (\v'->deg g v'==m) vs-                (Just c,g') = match v g-                i1          = indep g'-                i2          = v:indep (delNodes (neighbors' c) g')+-- | Calculate the maximum independent node set of the specified+--   graph.+indep :: (DynGraph gr) => gr a b -> [Node]+indep = fst . indepSize++-- | The maximum independent node set along with its size.+indepSize :: (DynGraph gr) => gr a b -> ([Node], Int)+indepSize g+  | isEmpty g = ([], 0)+  | l1 > l2   = il1+  | otherwise = 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')

@@ -4,7 +4,9 @@ module Data.Graph.Inductive.Query.MST (     msTreeAt,msTree,     -- * Path in MST-    msPath+    msPath,+    -- * Types used+    LRTree ) where  import           Data.Graph.Inductive.Graph@@ -12,7 +14,7 @@ import           Data.Graph.Inductive.Internal.RootPath  -newEdges :: Ord b => LPath b -> Context a b -> [H.Heap b (LPath b)]+newEdges :: LPath b -> Context a b -> [H.Heap b (LPath b)] newEdges (LP p) (_,_,_,s) = map (\(l,v)->H.unit l (LP ((v,l):p))) s  prim :: (Graph gr,Real b) => H.Heap b (LPath b) -> gr a b -> LRTree b@@ -24,16 +26,16 @@     where (_,p@(LP ((v,_):_)),h') = H.splitMin h  msTreeAt :: (Graph gr,Real b) => Node -> gr a b -> LRTree b-msTreeAt v g = prim (H.unit 0 (LP [(v,0)])) g+msTreeAt v = prim (H.unit 0 (LP [(v,0)]))  msTree :: (Graph gr,Real b) => gr a b -> LRTree b msTree g = msTreeAt v g where ((_,v,_,_),_) = matchAny g -msPath :: Real b => LRTree b -> Node -> Node -> Path+msPath :: LRTree b -> Node -> Node -> Path msPath t a b = joinPaths (getLPathNodes a t) (getLPathNodes b t)  joinPaths :: Path -> Path -> Path-joinPaths p q = joinAt (head p) p q+joinPaths p = joinAt (head p) p  joinAt :: Node -> Path -> Path -> Path joinAt _ (v:vs) (w:ws) | v==w = joinAt v vs ws

@@ -1,22 +1,25 @@ -- | Maximum Flow algorithm--- We are given a flow network G=(V,E) with source s and sink t where each--- edge (u,v) in E has a nonnegative capacity c(u,v)>=0, and we wish to--- find a flow of maximum value from s to t. ----- A flow in G=(V,E) is a real-valued function f:VxV->R that satisfies:+-- We are given a flow network @G=(V,E)@ with source @s@ and sink @t@+-- where each edge @(u,v)@ in @E@ has a nonnegative capacity+-- @c(u,v)>=0@, and we wish to find a flow of maximum value from @s@+-- to @t@. --+-- A flow in @G=(V,E)@ is a real-valued function @f:VxV->R@ that+-- satisfies:+-- -- @ -- For all u,v in V, f(u,v)\<=c(u,v) -- For all u,v in V, f(u,v)=-f(v,u) -- For all u in V-{s,t}, Sum{f(u,v):v in V } = 0 -- @ ----- The value of a flow f is defined as |f|=Sum {f(s,v)|v in V}, i.e.,+-- The value of a flow f is defined as @|f|=Sum {f(s,v)|v in V}@, i.e., -- the total net flow out of the source. ----- In this module we implement the Edmonds-Karp algorithm, which is the--- Ford-Fulkerson method but using the shortest path from s to t as the--- augmenting path along which the flow is incremented.+-- In this module we implement the Edmonds-Karp algorithm, which is+-- the Ford-Fulkerson method but using the shortest path from @s@ to+-- @t@ as the augmenting path along which the flow is incremented.  module Data.Graph.Inductive.Query.MaxFlow(     getRevEdges, augmentGraph, updAdjList, updateFlow, mfmg, mf, maxFlowgraph,@@ -39,10 +42,10 @@ -- Edges a\<--->b are ignored --          j -- @-getRevEdges :: (Num b,Ord b) => [(Node,Node)] -> [(Node,Node,b)]+getRevEdges :: (Num b) => [Edge] -> [LEdge b] getRevEdges [] = []-getRevEdges ((u,v):es) | notElem (v,u) es = (v,u,0):getRevEdges es-                       | otherwise        = getRevEdges (delete (v,u) es)+getRevEdges ((u,v):es) | (v,u) `notElem` es = (v,u,0):getRevEdges es+                       | otherwise          = getRevEdges (delete (v,u) es)  -- | -- @@@ -53,67 +56,76 @@ -- @ -- -- where label (x,y,z)=(Max Capacity, Current flow, Residual capacity)-augmentGraph :: (DynGraph gr,Num b,Ord b) => gr a b -> gr a (b,b,b)+augmentGraph :: (DynGraph gr, Num b) => gr a b -> gr a (b,b,b) augmentGraph g = emap (\i->(i,0,i)) (insEdges (getRevEdges (edges g)) g) --- | Given a successor or predecessor list for node u and given node v, find--- the label corresponding to edge (u,v) and update the flow and residual--- capacity of that edge's label. Then return the updated list.-updAdjList::(Num b,Ord b) => [((b,b,b),Node)]->Node->b->Bool->[((b,b,b),Node)]-updAdjList s v cf fwd | fwd == True = ((x,y+cf,z-cf),w):rs-                      | otherwise   = ((x,y-cf,z+cf),w):rs-                        where ((x,y,z),w) = head (filter (\(_,w')->v==w') s)-                              rs          = filter (\(_,w')->v/=w') s+-- | Given a successor or predecessor list for node @u@ and given node @v@, find+--   the label corresponding to edge @(u,v)@ and update the flow and+--   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'+  where+    (rs, ((x,y,z),w):rs') = break ((v==) . snd) s --- | Update flow and residual capacity along augmenting path from s to t in--- graph G. For a path [u,v,w,...] find the node u in G and its successor and--- predecessor list, then update the corresponding edges (u,v) and (v,u) on--- those lists by using the minimum residual capacity of the path.-updateFlow :: (DynGraph gr,Num b,Ord b) => Path -> b -> gr a (b,b,b) -> gr a (b,b,b)-updateFlow []       _ g = g+    cf' = if fwd+             then cf+             else negate cf++-- | Update flow and residual capacity along augmenting path from @s@ to @t@ in+--   graph @@G. For a path @[u,v,w,...]@ find the node @u@ in @G@ and+--   its successor and predecessor list, then update the corresponding+--   edges @(u,v)@ and @(v,u)@ on those lists by using the minimum+--   residual capacity of the path.+updateFlow :: (DynGraph gr, Num b) => Path -> b -> gr a (b,b,b) -> gr a (b,b,b)+updateFlow []        _ g = g updateFlow [_]       _ g = g updateFlow (u:v:vs) cf g = case match u g of-                             (Nothing,g')        -> g'+                             (Nothing,g')         -> g'                              (Just (p,u',l,s),g') -> (p',u',l,s') & g2-                                where g2 = updateFlow (v:vs) cf g'-                                      s' = updAdjList s v cf True-                                      p' = updAdjList p v cf False+                               where+                                 g2 = updateFlow (v:vs) cf g'+                                 s' = updAdjList s v cf True+                                 p' = updAdjList p v cf False --- | Compute the flow from s to t on a graph whose edges are labeled with--- (x,y,z)=(max capacity,current flow,residual capacity) and all edges--- are of the form a\<---->b. First compute the residual graph, that is,--- delete those edges whose residual capacity is zero. Then compute the--- shortest augmenting path from s to t, and finally update the flow and--- residual capacity along that path by using the minimum capacity of--- that path. Repeat this process until no shortest path from s to t exist.-mfmg :: (DynGraph gr,Num b,Ord b) => gr a (b,b,b) -> Node -> Node -> gr a (b,b,b)-mfmg g s t | augPath == [] = g-           | otherwise     = mfmg (updateFlow augPath minC g) s t-             where minC        = minimum (map ((\(_,_,z)->z).snd)(tail augLPath))-                   augPath     = map fst augLPath-                   LP augLPath = lesp s t gf-                   gf          = elfilter (\(_,_,z)->z/=0) g+-- | Compute the flow from @s@ to @t@ on a graph whose edges are labeled with+--   @(x,y,z)=(max capacity,current flow,residual capacity)@ and all+--   edges are of the form @a\<---->b@. First compute the residual+--   graph, that is, delete those edges whose residual capacity is+--   zero. Then compute the shortest augmenting path from @s@ to @t@,+--   and finally update the flow and residual capacity along that path+--   by using the minimum capacity of that path. Repeat this process+--   until no shortest path from @s@ to @t@ exist.+mfmg :: (DynGraph gr, Num b, Ord b) => gr a (b,b,b) -> Node -> Node -> gr a (b,b,b)+mfmg g s t+  | null augPath = g+  | otherwise    = mfmg (updateFlow augPath minC g) s t+  where+    minC        = minimum (map ((\(_,_,z)->z).snd)(tail augLPath))+    augPath     = map fst augLPath+    LP augLPath = lesp s t gf+    gf          = elfilter (\(_,_,z)->z/=0) g  -- | Compute the flow from s to t on a graph whose edges are labeled with--- x, which is the max capacity and where not all edges need to be of the--- form a\<---->b. Return the flow as a grap whose edges are labeled with--- (x,y,z)=(max capacity,current flow,residual capacity) and all edges--- are of the form a\<---->b-mf :: (DynGraph gr,Num b,Ord b) => gr a b -> Node -> Node -> gr a (b,b,b)-mf g s t = mfmg (augmentGraph g) s t+--   @x@, which is the max capacity and where not all edges need to be+--   of the form a\<---->b. Return the flow as a grap whose edges are+--   labeled with (x,y,z)=(max capacity,current flow,residual+--   capacity) and all edges are of the form a\<---->b+mf :: (DynGraph gr, Num b, Ord b) => gr a b -> Node -> Node -> gr a (b,b,b)+mf g = mfmg (augmentGraph g)  -- | Compute the maximum flow from s to t on a graph whose edges are labeled--- with x, which is the max capacity and where not all edges need to be of--- the form a\<---->b. Return the flow as a grap whose edges are labeled with--- (y,x) = (current flow, max capacity).-maxFlowgraph :: (DynGraph gr,Num b,Ord b) => gr a b -> Node -> Node -> gr a (b,b)-maxFlowgraph g s t = emap (\(u,v,_)->(v,u)) g2-                           where g2 = elfilter (\(x,_,_)->x/=0) g1-                                 g1 = mf g s t+--   with x, which is the max capacity and where not all edges need to+--   be of the form a\<---->b. Return the flow as a graph whose edges+--   are labeled with (y,x) = (current flow, max capacity).+maxFlowgraph :: (DynGraph gr, Num b, Ord b) => gr a b -> Node -> Node -> gr a (b,b)+maxFlowgraph g s t = emap (\(u,v,_)->(v,u))+                     . elfilter (\(x,_,_) -> x/=0 )+                     $ mf g s t  -- | Compute the value of a maximumflow-maxFlow :: (DynGraph gr,Num b,Ord b) => gr a b -> Node -> Node -> b-maxFlow g s t = foldr (+) 0 (map (\(_,_,(x,_))->x)(out (maxFlowgraph g s t) s))+maxFlow :: (DynGraph gr, Num b, Ord b) => gr a b -> Node -> Node -> b+maxFlow g s t = sum (map (fst . edgeLabel) (out (maxFlowgraph g s t) s))  ------------------------------------------------------------------------------ -- Some test cases: clr595 is from the CLR textbook, page 595. The value of

@@ -25,7 +25,7 @@  -- Data type for direction in which an edge is traversed data Direction = Forward | Backward-    deriving (Eq, Show)+    deriving (Eq, Ord, Show, Read)  -- Data type for edge with direction of traversal type DirEdge b = (Node, Node, b, Direction)@@ -33,7 +33,8 @@ type DirPath=[(Node, Direction)] type DirRTree=[DirPath] -pathFromDirPath = map (\(n,_)->n)+pathFromDirPath :: DirPath -> [Node]+pathFromDirPath = map fst  ------------------------------------------------------------------------------ -- Example networks@@ -111,16 +112,16 @@ 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 (\(c,f)->(c>f))+              Just (l, newg)    = extractEdge g u v (uncurry (>)) 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)) --- ekFusedStep :: EKStepFunc+ekFusedStep :: EKStepFunc ekFusedStep g s t = case maybePath of         Just _          ->-            Just ((insEdges (integrateDelta es delta) newg), delta)+            Just (insEdges (integrateDelta es delta) newg, delta)         Nothing   -> Nothing     where maybePath     = augPathFused g s t           (es, newg) = extractPathFused g (fromJust maybePath)@@ -160,8 +161,8 @@                     ((v, u, l, Backward):tailedges, newerg)                     where (tailedges, newerg) = extractPath newg (v:ws)                 Nothing               -> error "extractPath: revExtract == Nothing"-    where fwdExtract = extractEdge g u v (\(c,f)->(c>f))-          revExtract = extractEdge g v u (\(_,f)->(f>0))+    where fwdExtract = extractEdge g u v (uncurry (>))+          revExtract = extractEdge g v u ((>0) . snd)  -- Extract an edge from the graph that satisfies a given predicate -- Return the label on the edge and the graph without the edge@@ -172,7 +173,7 @@         Nothing      -> Nothing     where (Just (p', node, l, s), newg) = match u g           (adj, rest)=extractAdj s-              (\(l', dest) -> (dest==v) && (p l'))+              (\(l', dest) -> dest==v && p l')  -- Extract an item from an adjacency list that satisfies a given -- predicate. Return the item and the rest of the adjacency list@@ -186,24 +187,24 @@ getPathDeltas :: [DirEdge (Double,Double)] -> [Double] getPathDeltas []     = [] getPathDeltas (e:es) = case e of-    (_, _, (c,f), Forward)  -> (c-f) : (getPathDeltas es)-    (_, _, (_,f), Backward) -> f : (getPathDeltas es)+    (_, _, (c,f), Forward)  -> c-f : getPathDeltas es+    (_, _, (_,f), Backward) -> f : getPathDeltas es  integrateDelta :: [DirEdge (Double,Double)] -> Double     -> [LEdge (Double, Double)] integrateDelta []          _ = [] integrateDelta (e:es) delta = case e of     (u, v, (c, f), Forward) ->-        (u, v, (c, f+delta)) : (integrateDelta es delta)+        (u, v, (c, f+delta)) : integrateDelta es delta     (u, v, (c, f), Backward) ->-        (u, v, (c, f-delta)) : (integrateDelta es delta)+        (u, v, (c, f-delta)) : integrateDelta es delta  type EKStepFunc = Network -> Node -> Node -> Maybe (Network, Double)  ekSimpleStep :: EKStepFunc ekSimpleStep g s t = case maybePath of         Just _ ->-            Just ((insEdges (integrateDelta es delta) newg), delta)+            Just (insEdges (integrateDelta es delta) newg, delta)         Nothing   -> Nothing     where maybePath  = augPath g s t           (es, newg) = extractPath g (fromJust maybePath)@@ -212,7 +213,7 @@ ekWith :: EKStepFunc -> Network -> Node -> Node -> (Network, Double) ekWith stepfunc g s t = case stepfunc g s t of     Just (newg, delta) -> (finalg, capacity+delta)-        where (finalg, capacity) = (ekWith stepfunc newg s t)+        where (finalg, capacity) = ekWith stepfunc newg s t     Nothing            -> (g, 0)  ekSimple :: Network -> Node -> Node -> (Network, Double)@@ -227,10 +228,10 @@     -> ([DirEdge (Double, Double)], [LEdge (Double, Double)]) extractPathList []                 _ = ([], []) extractPathList (edge@(u,v,l@(c,f)):es) set-    | (c>f) && (S.member (u,v) set) =+    | (c>f) && S.member (u,v) set =         let (pathrest, notrest)=extractPathList es (S.delete (u,v) set)             in ((u,v,l,Forward):pathrest, notrest)-    | (f>0) && (S.member (v,u) set) =+    | (f>0) && S.member (v,u) set =         let (pathrest, notrest)=extractPathList es (S.delete (u,v) set)             in ((u,v,l,Backward):pathrest, notrest)     | otherwise                        =@@ -241,7 +242,7 @@ ekStepList g s t = case maybePath of         Just _  -> Just (mkGraph (labNodes g) newEdges, delta)         Nothing -> Nothing-    where newEdges      = (integrateDelta es delta) ++ otheredges+    where newEdges      = integrateDelta es delta ++ otheredges           maybePath     = augPathFused g s t           (es, otheredges) = extractPathList (labEdges g)               (S.fromList (zip justPath (tail justPath)))

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP, MultiParamTypeClasses #-}  -- (c) 2002 by Martin Erwig [see file COPYRIGHT] -- | Monadic Graph Algorithms@@ -28,10 +28,13 @@ --  ==> we can safely use imperative updates in the graph implementation -- -import Control.Applicative (Applicative (..))-import Control.Monad       (ap, liftM)+import Control.Monad (ap, liftM, liftM2) import Data.Tree +#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative (..))+#endif+ import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Monad @@ -57,42 +60,42 @@ newtype GT m g a = MGT (m g -> m (a,g))  apply :: GT m g a -> m g -> m (a,g)-apply (MGT f) mg = f mg+apply (MGT f) = f -apply' :: Monad m => GT m g a -> g -> m (a,g)+apply' :: (Monad m) => GT m g a -> g -> m (a,g) apply' gt = apply gt . return -applyWith :: Monad m => (a -> b) -> GT m g a -> m g -> m (b,g)+applyWith :: (Monad m) => (a -> b) -> GT m g a -> m g -> m (b,g) applyWith h (MGT f) gm = do {(x,g) <- f gm; return (h x,g)} -applyWith' :: Monad m => (a -> b) -> GT m g a -> g -> m (b,g)+applyWith' :: (Monad m) => (a -> b) -> GT m g a -> g -> m (b,g) applyWith' h gt = applyWith h gt . return -runGT :: Monad m => GT m g a -> m g -> m a+runGT :: (Monad m) => GT m g a -> m g -> m a runGT gt mg = do {(x,_) <- apply gt mg; return x} -instance Monad m => Functor (GT m g) where+instance (Monad m) => Functor (GT m g) where     fmap  = liftM -instance Monad m => Applicative (GT m g) where+instance (Monad m) => Applicative (GT m g) where     pure  = return     (<*>) = ap -instance Monad m => Monad (GT m g) where+instance (Monad m) => Monad (GT m g) where   return x = MGT (\mg->do {g<-mg; return (x,g)})   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+condMGT' :: (Monad m) => (s -> Bool) -> GT m s a -> GT m s a -> GT m s a condMGT' p f g = MGT (\mg->do {h<-mg; if p h then apply f mg else apply g mg}) -recMGT' :: Monad m => (s -> Bool) -> GT m s a -> (a -> b -> b) -> b -> GT m s b+recMGT' :: (Monad m) => (s -> Bool) -> GT m s a -> (a -> b -> b) -> b -> GT m s b recMGT' p mg f u = condMGT' p (return u)                             (do {x<-mg;y<-recMGT' p mg f u;return (f x y)}) -condMGT :: Monad m => (m s -> m Bool) -> GT m s a -> GT m s a -> GT m s a+condMGT :: (Monad m) => (m s -> m Bool) -> GT m s a -> GT m s a -> GT m s a condMGT p f g = MGT (\mg->do {b<-p mg; if b then apply f mg else apply g mg}) -recMGT :: Monad m => (m s -> m Bool) -> GT m s a -> (a -> b -> b) -> b -> GT m s b+recMGT :: (Monad m) => (m s -> m Bool) -> GT m s a -> (a -> b -> b) -> b -> GT m s b recMGT p mg f u = condMGT p (return u)                           (do {x<-mg;y<-recMGT p mg f u;return (f x y)}) @@ -104,35 +107,32 @@  -- some monadic graph accessing functions ---getNode :: GraphM m gr => GT m (gr a b) Node+getNode :: (GraphM m gr) => GT m (gr a b) Node getNode = MGT (\mg->do {((_,v,_,_),g) <- matchAnyM mg; return (v,g)}) -getContext :: GraphM m gr => GT m (gr a b) (Context a b)+getContext :: (GraphM m gr) => GT m (gr a b) (Context a b) getContext = MGT matchAnyM  -- some functions defined by using the do-notation explicitly -- Note: most of these can be expressed as an instance of graphRec -- getNodes' :: (Graph gr,GraphM m gr) => GT m (gr a b) [Node]-getNodes' = condMGT' isEmpty (return [])-                             (do v  <- getNode-                                 vs <- getNodes-                                 return (v:vs))+getNodes' = condMGT' isEmpty (return []) nodeGetter -getNodes :: GraphM m gr => GT m (gr a b) [Node]-getNodes = condMGT isEmptyM (return [])-                            (do v  <- getNode-                                vs <- getNodes-                                return (v:vs))+getNodes :: (GraphM m gr) => GT m (gr a b) [Node]+getNodes = condMGT isEmptyM (return []) nodeGetter -sucGT :: GraphM m gr => Node -> GT m (gr a b) (Maybe [Node])+nodeGetter :: (GraphM m gr) => GT m (gr a b) [Node]+nodeGetter = liftM2 (:) getNode getNodes++sucGT :: (GraphM m gr) => Node -> GT m (gr a b) (Maybe [Node]) sucGT v = MGT (\mg->do (c,g) <- matchM v mg                        case c of                          Just (_,_,_,s) -> return (Just (map snd s),g)                          Nothing        -> return (Nothing,g)               ) -sucM :: GraphM m gr => Node -> m (gr a b) -> m (Maybe [Node])+sucM :: (GraphM m gr) => Node -> m (gr a b) -> m (Maybe [Node]) sucM v = runGT (sucGT v)  @@ -149,7 +149,7 @@ --                                   return (g x y))  -- | encapsulates a simple recursion schema on graphs-graphRec :: GraphM m gr => GT m (gr a b) c ->+graphRec :: (GraphM m gr) => GT m (gr a b) c ->                            (c -> d -> d) -> d -> GT m (gr a b) d graphRec = recMGT isEmptyM @@ -157,7 +157,7 @@                            (c -> d -> d) -> d -> GT m (gr a b) d graphRec' = recMGT' isEmpty -graphUFold :: GraphM m gr => (Context a b -> c -> c) -> c -> GT m (gr a b) c+graphUFold :: (GraphM m gr) => (Context a b -> c -> c) -> c -> GT m (gr a b) c graphUFold = graphRec getContext  @@ -168,20 +168,20 @@  -- instances of graphRec ---graphNodesM0 :: GraphM m gr => GT m (gr a b) [Node]+graphNodesM0 :: (GraphM m gr) => GT m (gr a b) [Node] graphNodesM0 = graphRec getNode (:) [] -graphNodesM :: GraphM m gr => GT m (gr a b) [Node]+graphNodesM :: (GraphM m gr) => GT m (gr a b) [Node] graphNodesM = graphUFold (\(_,v,_,_)->(v:)) [] -graphNodes :: GraphM m gr => m (gr a b) -> m [Node]+graphNodes :: (GraphM m gr) => m (gr a b) -> m [Node] graphNodes = runGT graphNodesM -graphFilterM :: GraphM m gr => (Context a b -> Bool) ->+graphFilterM :: (GraphM m gr) => (Context a b -> Bool) ->                               GT m (gr a b) [Context a b] graphFilterM p = graphUFold (\c cs->if p c then c:cs else cs) [] -graphFilter :: GraphM m gr => (Context a b -> Bool) -> m (gr a b) -> m [Context a b]+graphFilter :: (GraphM m gr) => (Context a b -> Bool) -> m (gr a b) -> m [Context a b] graphFilter p = runGT (graphFilterM p)  @@ -197,7 +197,7 @@ --  (2) run the graph transformer (applied to arguments) (e.g., dfsM) -- -dfsGT :: GraphM m gr => [Node] -> GT m (gr a b) [Node]+dfsGT :: (GraphM m gr) => [Node] -> GT m (gr a b) [Node] dfsGT []     = return [] dfsGT (v:vs) = MGT (\mg->                do (mc,g') <- matchM v mg@@ -206,15 +206,15 @@                     Nothing        -> apply' (dfsGT vs) g'  )  -- | depth-first search yielding number of nodes-dfsM :: GraphM m gr => [Node] -> m (gr a b) -> m [Node]+dfsM :: (GraphM m gr) => [Node] -> m (gr a b) -> m [Node] dfsM vs = runGT (dfsGT vs) -dfsM' :: GraphM m gr => m (gr a b) -> m [Node]+dfsM' :: (GraphM m gr) => m (gr a b) -> m [Node] dfsM' mg = do {vs <- nodesM mg; runGT (dfsGT vs) mg}   -- | depth-first search yielding dfs forest-dffM :: GraphM m gr => [Node] -> GT m (gr a b) [Tree Node]+dffM :: (GraphM m gr) => [Node] -> GT m (gr a b) [Tree Node] dffM vs = MGT (\mg->           do g<-mg              b<-isEmptyM mg@@ -228,8 +228,8 @@                                    return (Node (node' c) ts:ts',g3)           ) -graphDff :: GraphM m gr => [Node] -> m (gr a b) -> m [Tree Node]+graphDff :: (GraphM m gr) => [Node] -> m (gr a b) -> m [Tree Node] graphDff vs = runGT (dffM vs) -graphDff' :: GraphM m gr => m (gr a b) -> m [Tree Node]+graphDff' :: (GraphM m gr) => m (gr a b) -> m [Tree Node] graphDff' mg = do {vs <- nodesM mg; runGT (dffM vs) mg}

@@ -1,8 +1,13 @@ -- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT] +-- | Shortest path algorithms module Data.Graph.Inductive.Query.SP(-    spTree,spLength,sp,-    dijkstra+      spTree+    , sp+    , spLength+    , dijkstra+    , LRTree+    , H.Heap ) where  import qualified Data.Graph.Inductive.Internal.Heap as H@@ -10,11 +15,14 @@ import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Internal.RootPath -expand :: Real b => b -> LPath b -> Context a b -> [H.Heap b (LPath b)]+expand :: (Real b) => b -> LPath b -> Context a b -> [H.Heap b (LPath b)] expand d (LP p) (_,_,_,s) = map (\(l,v)->H.unit (l+d) (LP ((v,l+d):p))) s --- | Implementation of Dijkstra's shortest path algorithm-dijkstra :: (Graph gr, Real b) => H.Heap b (LPath b) -> gr a b -> LRTree b+-- | Dijkstra's shortest path algorithm.+dijkstra :: (Graph gr, Real b)+    => H.Heap b (LPath b) -- ^ Initial heap of known paths and their lengths.+    -> gr a b+    -> LRTree b dijkstra h g | H.isEmpty h || isEmpty g = [] dijkstra h g =     case match v g of@@ -22,11 +30,29 @@          (Nothing,g') -> dijkstra h' g'     where (_,p@(LP ((v,d):_)),h') = H.splitMin h -spTree :: (Graph gr, Real b) => Node -> gr a b -> LRTree b+-- | Tree of shortest paths from a certain node to the rest of the+--   (reachable) nodes.+--+--   Corresponds to 'dijkstra' applied to a heap in which the only known node is+--   the starting node, with a path of length 0 leading to it.+spTree :: (Graph gr, Real b)+    => Node+    -> gr a b+    -> LRTree b spTree v = dijkstra (H.unit 0 (LP [(v,0)])) -spLength :: (Graph gr, Real b) => Node -> Node -> gr a b -> b+-- | Length of the shortest path between two nodes.+spLength :: (Graph gr, Real b)+    => Node -- ^ Start+    -> Node -- ^ Destination+    -> gr a b+    -> b spLength s t = getDistance t . spTree s -sp :: (Graph gr, Real b) => Node -> Node -> gr a b -> Path+-- | Shortest path between two nodes.+sp :: (Graph gr, Real b)+    => Node -- ^ Start+    -> Node -- ^ Destination+    -> gr a b+    -> Path sp s t = getLPathNodes t . spTree s

@@ -6,15 +6,16 @@ import Data.Graph.Inductive.Query.DFS (reachable)  -getNewEdges :: DynGraph gr => [LNode a] -> gr a b -> [LEdge ()]-getNewEdges vs g = concatMap (\(u,_)->r u g) vs-                   where r = \u g' -> map (\v->(u,v,())) (reachable u g')+getNewEdges :: (DynGraph gr) => [LNode a] -> gr a b -> [LEdge ()]+getNewEdges vs g = map (`toLEdge` ())+                   . concatMap (\u -> map ((,) u) (reachable u g))+                   $ map fst vs  {-| Finds the transitive closure of a directed graph. Given a graph G=(V,E), its transitive closure is the graph: G* = (V,E*) where E*={(i,j): i,j in V and there is a path from i to j in G} -}-trc :: DynGraph gr => gr a b -> gr a ()+trc :: (DynGraph gr) => gr a b -> gr a () trc g = insEdges (getNewEdges ln g) (insNodes ln empty)         where ln = labNodes g

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif+ -- (c) 1999 - 2002 by Martin Erwig [see file COPYRIGHT] -- | Tree-based implementation of 'Graph' and 'DynGraph' --@@ -9,17 +14,24 @@ import Data.Graph.Inductive.Graph  import           Control.Applicative (liftA2)-import           Control.Arrow       (first)+import           Control.Arrow       (first, second)+import           Control.DeepSeq     (NFData (..)) import           Data.List           (foldl', sort) import           Data.Map            (Map) import qualified Data.Map            as M import           Data.Maybe          (fromMaybe)+#if __GLASGOW_HASKELL__ >= 702+import           GHC.Generics        (Generic)+#endif  ---------------------------------------------------------------------- -- GRAPH REPRESENTATION ----------------------------------------------------------------------  newtype Gr a b = Gr (GraphRep a b)+#if __GLASGOW_HASKELL__ >= 702+  deriving (Generic)+#endif  type GraphRep a b = Map Node (Context' a b) type Context' a b = (Adj b,a,Adj b)@@ -33,7 +45,7 @@ instance (Eq a, Ord b) => Eq (Gr a b) where   (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2     where-      sortAdj (a1,n,a2) = (sort a1,n,sort a2)+      sortAdj (p,n,s) = (sort p,n,sort s)  instance (Show a, Show b) => Show (Gr a b) where   showsPrec d g = showParen (d > 10) $@@ -53,27 +65,34 @@ -- instance Graph Gr where   empty             = Gr M.empty+   isEmpty (Gr g)    = M.null g+   match v gr@(Gr g) = maybe (Nothing, gr)                             (first Just . uncurry (cleanSplit v))                       . (\(m,g') -> fmap (flip (,) g') m)                       $ M.updateLookupWithKey (const (const Nothing)) v g-  mkGraph vs es     = (insEdges' . insNodes vs) empty-        where-          insEdges' g = foldl' (flip insEdge) g es +  mkGraph vs es     = insEdges es+                      . Gr+                      . M.fromList+                      . map (second (\l -> ([],l,[])))+                      $ vs+   labNodes (Gr g)   = map (\(v,(_,l,_))->(v,l)) (M.toList g)-  -- more efficient versions of derived class members-  --+   matchAny (Gr g)   = maybe (error "Match Exception, Empty Graph")                             (uncurry (uncurry cleanSplit))                             (M.minViewWithKey g)+   noNodes   (Gr g)  = M.size g-  nodeRange (Gr g)  = fromMaybe (0,0)++  nodeRange (Gr g)  = fromMaybe (error "nodeRange of empty graph")                       $ liftA2 (,) (ix (M.minViewWithKey g))                                    (ix (M.maxViewWithKey g))     where       ix            = fmap (fst . fst)+   labEdges  (Gr g)  = concatMap (\(v,(_,_,s))->map (\(l,w)->(v,w,l)) s) (M.toList g)  -- After a Node (with its corresponding Context') are split out of a@@ -101,6 +120,9 @@       addCntxt = maybe (Just cntxt')                        (const (error ("Node Exception, Node: "++show v)))       cntxt' = (p,l,s)++instance (NFData a, NFData b) => NFData (Gr a b) where+  rnf (Gr g) = rnf g  ---------------------------------------------------------------------- -- UTILITIES

@@ -0,0 +1,358 @@+{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{- |+   Module      : Data.Graph.Inductive.Arbitrary+   Description : Arbitrary definition for fgl graphs+   Copyright   : (c) Ivan Lazar Miljenovic+   License     : BSD3+   Maintainer  : Ivan.Miljenovic@gmail.com++This module provides default definitions for use with QuickCheck's+'Arbitrary' class.++Both "Data.Graph.Inductive.Tree"- and+"Data.Graph.Inductive.PatriciaTree"-based graph implementations have+'Arbitrary' instances.  In most cases, this is all you will need.++If, however, you want to create arbitrary custom graph-like data+structures, then you will probably want to do some custom processing+from an arbitrary 'GraphNodesEdges' value, either directly or with a+custom 'ArbGraph' instance.++ -}+module Data.Graph.Inductive.Arbitrary+       ( -- * Explicit graph creation+         -- $explicit+         arbitraryGraph+       , arbitraryGraphWith+       , shrinkGraph+       , shrinkGraphWith+         -- * Types of graphs+       , ArbGraph(..)+       , GrProxy(..)+       , shrinkF+       , arbitraryGraphBy+         -- ** Specific graph structures+       , NoMultipleEdges(..)+       , NoLoops(..)+       , SimpleGraph+       , Undirected(..)+         -- ** Connected graphs+       , Connected(..)+       , connGraph+         -- * Node and edge lists+       , arbitraryNodes+       , arbitraryEdges+       , GraphNodesEdges(..)+       ) where++import           Data.Graph.Inductive.Graph        (DynGraph, Graph, LEdge,+                                                    LNode, Node, delNode,+                                                    insEdges, insNode, mkGraph,+                                                    newNodes, nodes, toEdge)+import qualified Data.Graph.Inductive.PatriciaTree as P+import qualified Data.Graph.Inductive.Tree         as T++import Test.QuickCheck (Arbitrary (..), Gen, elements, listOf)++import Control.Applicative (liftA3)+import Control.Arrow       (second)+import Data.Function       (on)+import Data.List           (deleteBy, groupBy, sortBy)+import Data.Maybe          (mapMaybe)++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>), (<*>))+#endif++-- -----------------------------------------------------------------------------++-- | Generally a list of labelled nodes.+arbitraryNodes :: (Arbitrary a) => Gen [LNode a]+arbitraryNodes = arbitrary >>= mapM ((<$> arbitrary) . (,)) . uniq++-- | Given a specified list of nodes, generate a list of edges.+arbitraryEdges :: (Arbitrary b) => [LNode a] -> Gen [LEdge b]+arbitraryEdges lns+  | null lns  = return []+  | otherwise = listOf (liftA3 (,,) nGen nGen arbitrary)+  where+    nGen = elements (map fst lns)++-- | Defined so as to be able to generate valid 'arbitrary' node and+--   edge lists.+--+--   If any specific structure (no multiple edges, no loops, etc.) is+--   required then you will need to post-process this after generating+--   it, or else create a new instance of 'ArbGraph'.+data GraphNodesEdges a b = GNEs { graphNodes :: [LNode a]+                                , graphEdges :: [LEdge b]+                                }+  deriving (Eq, Ord, Show, Read)++instance (Arbitrary a, Arbitrary b) => Arbitrary (GraphNodesEdges a b) where+  arbitrary = do ns <- arbitraryNodes+                 GNEs ns <$> arbitraryEdges ns++  shrink (GNEs ns es) = case ns of+                          _:_:_ -> map delN ns+                          _     -> []+    where+      delN ln@(n,_) = GNEs ns' es'+        where+          ns' = deleteBy ((==)`on`fst) ln ns+          es' = filter (not . hasN) es++          hasN (v,w,_) = v == n || w == n++-- -----------------------------------------------------------------------------++-- | Representation of generating arbitrary graph structures.+--+--   Typically, you would only use this for the 'toBaseGraph' function+--   or if you wanted to make a custom graph wrapper.+--+--   The intent of this class is to simplify defining and using+--   different wrappers on top of graphs (e.g. you may wish to have an+--   'Undirected' graph, or one with 'NoLoops', or possibly both!).+class (DynGraph (BaseGraph ag)) => ArbGraph ag where+  type BaseGraph ag :: * -> * -> *++  toBaseGraph :: ag a b -> BaseGraph ag a b++  fromBaseGraph :: BaseGraph ag a b -> ag a b++  -- | Any manipulation of edges that should be done to satisfy the+  --   requirements of the specified wrapper.+  edgeF :: GrProxy ag -> [LEdge b] -> [LEdge b]++  -- | Shrinking function (assuming only one node is removed at a+  --   time) which also returns the node that is removed.+  shrinkFWith :: ag a b -> [(Node, ag a b)]++-- | In most cases, for an instance of 'ArbGraph' the 'Arbitrary'+--   instance definition will\/can have @shrink = shrinkF@.+shrinkF :: (ArbGraph ag) => ag a b -> [ag a b]+shrinkF = map snd . shrinkFWith++instance ArbGraph T.Gr where+  type BaseGraph T.Gr = T.Gr++  toBaseGraph = id+  fromBaseGraph = id++  edgeF _ = id++  shrinkFWith = shrinkGraphWith++instance ArbGraph P.Gr where+  type BaseGraph P.Gr = P.Gr++  toBaseGraph = id+  fromBaseGraph = id++  edgeF _ = id++  shrinkFWith = shrinkGraphWith++-- | A simple graph-specific proxy type.+data GrProxy (gr :: * -> * -> *) = GrProxy+  deriving (Eq, Ord, Show, Read)++-- -----------------------------------------------------------------------------++{- $explicit++If you wish to explicitly create a generated graph value (rather than+using the 'Arbitrary' class) then you will want to use these+functions.++-}++-- | Generate an arbitrary graph.  Multiple edges are allowed.+arbitraryGraph :: (Graph gr, Arbitrary a, Arbitrary b) => Gen (gr a b)+arbitraryGraph = arbitraryGraphWith id++-- | Generate an arbitrary graph, using the specified function to+--   manipulate the generated list of edges (e.g. remove multiple+--   edges).+arbitraryGraphWith :: (Graph gr, Arbitrary a, Arbitrary b)+                      => ([LEdge b] -> [LEdge b]) -> Gen (gr a b)+arbitraryGraphWith f = do GNEs ns es <- arbitrary+                          let es' = f es+                          return (mkGraph ns es')++-- | Generate an instance of 'ArbGraph' using the class methods.+arbitraryGraphBy :: forall ag a b. (ArbGraph ag, Arbitrary a, Arbitrary b)+                    => Gen (ag a b)+arbitraryGraphBy = fromBaseGraph+                   <$> arbitraryGraphWith (edgeF (GrProxy :: GrProxy ag))++-- Ensure we have a list of unique Node values; this will also sort+-- the list, but that shouldn't matter.+uniq :: [Node] -> [Node]+uniq = uniqBy id++uniqBy :: (Ord b) => (a -> b) -> [a] -> [a]+uniqBy f = map head . groupBy ((==) `on` f) . sortBy (compare `on` f)++-- | For a graph with at least two nodes, return every possible way of+--   deleting a single node (i.e. will never shrink to an empty+--   graph).+shrinkGraph :: (Graph gr) => gr a b -> [gr a b]+shrinkGraph = map snd . shrinkGraphWith++-- | As with 'shrinkGraph', but also return the node that was deleted.+shrinkGraphWith :: (Graph gr) => gr a b -> [(Node, gr a b)]+shrinkGraphWith gr = case nodes gr of+                       -- Need to have at least 2 nodes before we delete one!+                       ns@(_:_:_) -> map ((,) <*> (`delNode` gr)) ns+                       _          -> []++instance (Arbitrary a, Arbitrary b) => Arbitrary (T.Gr a b) where+  arbitrary = arbitraryGraph++  shrink = shrinkGraph++instance (Arbitrary a, Arbitrary b) => Arbitrary (P.Gr a b) where+  arbitrary = arbitraryGraph++  shrink = shrinkGraph++-- | A newtype wrapper to generate a graph without multiple edges+--   (loops allowed).+newtype NoMultipleEdges gr a b = NME { nmeGraph :: gr a b }+                                 deriving (Eq, Show, Read)++instance (ArbGraph gr) => ArbGraph (NoMultipleEdges gr) where+  type BaseGraph (NoMultipleEdges gr) = BaseGraph gr++  toBaseGraph = toBaseGraph. nmeGraph+  fromBaseGraph = NME . fromBaseGraph++  edgeF _ = uniqBy toEdge . edgeF (GrProxy :: GrProxy gr)++  shrinkFWith = map (second NME) . shrinkFWith . nmeGraph++instance (ArbGraph gr, Arbitrary a, Arbitrary b) => Arbitrary (NoMultipleEdges gr a b) where+  arbitrary = arbitraryGraphBy++  shrink = shrinkF++-- | A newtype wrapper to generate a graph without loops (multiple+--   edges allowed).+newtype NoLoops gr a b = NL { looplessGraph :: gr a b }+                         deriving (Eq, Show, Read)++instance (ArbGraph gr) => ArbGraph (NoLoops gr) where+  type BaseGraph (NoLoops gr) = BaseGraph gr++  toBaseGraph = toBaseGraph . looplessGraph+  fromBaseGraph = NL . fromBaseGraph++  edgeF _ = filter notLoop . edgeF (GrProxy :: GrProxy gr)++  shrinkFWith = map (second NL) . shrinkFWith . looplessGraph++notLoop :: LEdge b -> Bool+notLoop (v,w,_) = v /= w++instance (ArbGraph gr, Arbitrary a, Arbitrary b) => Arbitrary (NoLoops gr a b) where+  arbitrary = arbitraryGraphBy++  shrink = shrinkF++-- | A wrapper to generate a graph without multiple edges and+--   no loops.+type SimpleGraph gr = NoLoops (NoMultipleEdges gr)++-- | A newtype wrapper such that each (non-loop) edge also has its+--   reverse in the graph.+--+--   Note that there is no way to guarantee this after any additional+--   edges are added or removed.+--+--  You should also apply this wrapper /after/ 'NoMultipleEdges' or+--  else the wrong reverse edge might be removed.+newtype Undirected gr a b = UG { undirGraph :: gr a b }+                            deriving (Eq, Show, Read)++instance (ArbGraph gr) => ArbGraph (Undirected gr) where+  type BaseGraph (Undirected gr) = BaseGraph gr++  toBaseGraph = toBaseGraph . undirGraph+  fromBaseGraph = UG . fromBaseGraph++  edgeF _ = undirect . edgeF (GrProxy :: GrProxy gr)++  shrinkFWith = map (second UG) . shrinkFWith . undirGraph++undirect :: [LEdge b] -> [LEdge b]+undirect = concatMap undir+  where+    undir le@(v,w,b)+      | notLoop le = [le, (w,v,b)]+      | otherwise  = [le]++instance (ArbGraph gr, Arbitrary a, Arbitrary b) => Arbitrary (Undirected gr a b) where+  arbitrary = arbitraryGraphBy++  shrink = shrinkF++-- -----------------------------------------------------------------------------++-- | A brute-force approach to generating connected graphs.+--+--   The resultant graph (obtained with 'connGraph') will /never/ be+--   empty: it will, at the very least, contain an additional+--   connected node (obtained with 'connNode').+--+--   Note that this is /not/ an instance of 'ArbGraph' as it is not+--   possible to arbitrarily layer a transformer on top of this.+data Connected ag a b = CG { connNode     :: Node+                           , connArbGraph :: ag a b+                           }+                        deriving (Eq, Show, Read)++instance (ArbGraph ag, Arbitrary a, Arbitrary b) => Arbitrary (Connected ag a b) where+  arbitrary = arbitraryGraphBy >>= toConnGraph++  shrink = shrinkConnGraph++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+                                }+  where+    g = toBaseGraph ag++    [v] = newNodes 1 g++    ws = nodes g++    mkE w = do b <- arbitrary+               return (edgeF p [(v,w,b)])++    p :: GrProxy ag+    p = GrProxy++shrinkConnGraph :: (ArbGraph ag) => Connected ag a b -> [Connected ag a b]+shrinkConnGraph cg = mapMaybe keepConn . shrinkFWith $ g+  where+    v = connNode cg+    g = connArbGraph cg++    keepConn (w,sgs) | v == w    = Nothing+                     | otherwise = Just (cg { connArbGraph = sgs })++-- | The underlying graph represented by this 'Connected' value.+connGraph :: (ArbGraph ag) => Connected ag a b -> BaseGraph ag a b+connGraph = toBaseGraph . connArbGraph++-- -----------------------------------------------------------------------------

@@ -1,5 +1,5 @@ name:          fgl-version:       5.5.1.0+version:       5.5.2.0 license:       BSD3 license-file:  LICENSE author:        Martin Erwig, Ivan Lazar Miljenovic@@ -12,7 +12,7 @@ . Original website can be found at <http://web.engr.oregonstate.edu/~erwig/fgl/haskell>. }-cabal-version: >= 1.6+cabal-version: >= 1.10 build-type:    Simple extra-source-files:                ChangeLog@@ -22,6 +22,8 @@     location:     git://github.com/haskell/fgl.git  library {+    default-language: Haskell98+     exposed-modules:         Data.Graph.Inductive.Internal.Heap,         Data.Graph.Inductive.Internal.Queue,@@ -54,5 +56,42 @@     other-modules:         Paths_fgl -    build-depends:    base < 5, mtl, containers, array+    build-depends:    base < 5+                    , transformers+                    , containers+                    , array+                    , deepseq >= 1.1.0.0 && < 1.5.0.0++    if impl(ghc >= 7.2) && impl(ghc < 7.6)+        build-depends:+            ghc-prim++    ghc-options:      -Wall++}++test-suite fgl-tests {+    default-language: Haskell98++    type:             exitcode-stdio-1.0++    build-depends:    fgl+                    , base+                    , QuickCheck >= 2.8 && < 2.9+                    , hspec == 2.1.*+                    , containers++    hs-source-dirs:   test+                      fgl-arbitrary++    main-is:          TestSuite.hs++    other-modules:    Data.Graph.Inductive.Arbitrary+                    , Data.Graph.Inductive.Graph.Properties+                    , Data.Graph.Inductive.Proxy+                    , Data.Graph.Inductive.Query.Properties++    ghc-options:      -Wall++    ghc-prof-options: -prof -auto }

@@ -0,0 +1,410 @@+{-# LANGUAGE CPP #-}++{- |+   Module      : Data.Graph.Inductive.Properties+   Description : Expected properties of inductive graphs+   Copyright   : (c) Ivan Lazar Miljenovic+   License     : BSD3+   Maintainer  : Ivan.Miljenovic@gmail.com++++ -}+module Data.Graph.Inductive.Graph.Properties where++import Data.Graph.Inductive+import Data.Graph.Inductive.Arbitrary+import Data.Graph.Inductive.Proxy++import Test.QuickCheck++import           Control.Applicative (liftA2)+import           Control.Arrow       ((***))+import           Data.Function       (on)+import           Data.List           (groupBy, sort, sortBy)+import qualified Data.Set            as S++#if __GLASGOW_HASKELL__ < 710+import Data.Functor ((<$>))+#endif++{-# ANN module "HLint: ignore Use camelCase" #-}++-- -----------------------------------------------------------------------------+-- Non-dynamic graphs++-- | Ensure that a custom 'Eq' instance matches the behaviour of the+--   'equal' function.+valid_Eq :: (Graph gr, Eq a, Eq b, Eq (gr a b)) => gr a b -> gr a b -> Bool+valid_Eq g1 g2 = (equal g1 g1 && g1 == g1)+                 && (equal g2 g2 && g2 == g2)+                 && (equal g1 g2 == (g1 == g2))++-- | Ensure that the definition of 'noNodes' matches the default+--   implementation.+valid_node_count :: (Graph gr) => gr a b -> Bool+valid_node_count g = noNodes g == length (nodes g)++-- | Ensure that the definition of 'nodeRange' matches the default+--   implementation.+valid_nodeRange :: (Graph gr) => gr a b -> Property+valid_nodeRange g = not (isEmpty g) ==>+                        nodeRange g == (minimum vs, maximum vs)+  where+    vs = nodes g++-- | Make sure that a graph created with specified nodes contains+--   those nodes (and only those nodes) and no edges are created.+valid_mkGraph_nodes :: (Graph gr, Arbitrary a, Eq a) => Proxy (gr a b) -> Gen Bool+valid_mkGraph_nodes p = do ns <- arbitraryNodes+                           let g = mkGraph ns [] `asProxyTypeOf` p+                           return ( sortOn fst (labNodes g) == ns+                                    && null (labEdges g))++-- | Make sure that a graph created with specified edges contains+--   those edges (and only those edges), and that no additional nodes+--   are created.+valid_mkGraph_edges :: (Graph gr, Eq a, Eq b) => Proxy (gr a b)+                       -> GraphNodesEdges a b  -> Bool+valid_mkGraph_edges p (GNEs ns es) = sortOn toEdge (labEdges g) == es'+                                     && sortOn fst (labNodes g) == ns+  where+    es' = uniqBy toEdge es++    g = mkGraph ns es' `asProxyTypeOf` p++-- | The resultant graph shouldn't matter on the order of nodes and+--   edges provided.+valid_mkGraph_order :: (Graph gr, Eq a, Eq b) => Proxy (gr a b)+                       -> GraphNodesEdges a b -> Bool+valid_mkGraph_order p (GNEs ns es) = all (equal g)+                                         [ mkGraph ns  esR+                                         , mkGraph nsR es+                                         , mkGraph nsR esR+                                         ]+  where+    g = mkGraph ns es `asProxyTypeOf` p++    nsR = reverse ns+    esR = reverse es++-- | Ensure that when a node is matched, it is indeed removed from the+--   resulting graph.+valid_match :: (Graph gr) => gr a b -> Property+valid_match g = not (isEmpty g) ==> check_match <$> elements (nodes g)+  where+    order = noNodes g++    check_match n = maybe False check_context mc+      where+        (mc, g') = match n g++        check_context c = (node' c `notElem` nodes g')+                          && (noNodes g' == order - 1)+                          -- Edges were previously in the graph+                          && all (elem (node' c) . pre g) (sucC c)+                          && all (elem (node' c) . suc g) (preC c)+                          -- Edges not in new graph+                          && all (notElem (node' c) . pre g') (sucC c)+                          && all (notElem (node' c) . suc g') (preC c)++-- | Ensure that 'matchAny' is valid by verifying that it achieves the+--   same result as matching for that node specifically.+valid_matchAny :: (Graph gr, Eq a, Ord b) => gr a b -> Property+valid_matchAny g = not (isEmpty g) ==>+                     (uncurry (&&)+                     . (maybe False ((c'==) . sortContext) *** equal g')+                     $ match (node' c) g)+  where+    (c,g') = matchAny g++    c' = sortContext c++-- | newNodes should return Nodes that aren't already in the graph.+newNodes_really_new :: (Graph gr) => gr a b -> NonNegative Int -> Bool+newNodes_really_new g (NonNegative n) = liftA2 (&&) (all (not . (`gelem`g)))+                                                 ((n==) . length)+                                       (newNodes n g)++-- | ufold should create a Context for each node.+ufold_all_nodes :: (Graph gr) => gr a b -> Bool+ufold_all_nodes g = sort (ufold ((:) . node') [] g)+                    == sort (nodes g)++-- | All nodes should indeed be elements of the graph.+all_nodes_gelem :: (Graph gr) => gr a b -> Bool+all_nodes_gelem g = all (`gelem`g) (nodes g)++-- | If a potential 'Node' is 'gelem' then it should also be in the+--   output of 'nodes'.+gelem_in_nodes :: (Graph gr) => gr a b -> [Node] -> Bool+gelem_in_nodes g = all (liftA2 (==) (`gelem`g) (`S.member`ns))+  where+    ns = S.fromList $ nodes g++-- | Check that having a labelled edge in a graph is equivalent to+-- 'hasNeighborAdj' reporting that the edge is there.+valid_hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> Node -> b -> Bool+valid_hasNeighborAdj gr v w l = any (`elem` [(v,w,l), (w,v,l)]) (labEdges gr)+                                == (hasNeighborAdj gr v (l,w) && hasNeighborAdj gr w (l,v))++-- | Check that having an edge in a graph is equivalent to+-- 'hasNeighbor' reporting that the edge is there.+valid_hasNeighbor :: (Graph gr) => gr a b -> Node -> Node -> Bool+valid_hasNeighbor gr v w =+  any (`elem` [(v,w), (w,v)]) (edges gr) == (hasNeighbor gr v w && hasNeighbor gr w v)++-- | Check that having a labelled edge in a graph is equivalent to+-- 'hasLEdge' reporting that the edge is there.+valid_hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool+valid_hasLEdge gr e = (e `elem` labEdges gr) == hasLEdge gr e++-- -----------------------------------------------------------------------------+-- Dynamic graphs++-- | Ensure that matching and then merging using '&' produces the+--   original graph again.+--+--   We do it this way because it isn't possible to generate an+--   arbitrary 'Context' to test against; 'valid_match' \"proves\"+--   that matching is valid, so if merging produces the original graph+--   again then it must be valid as well.+valid_merge :: (DynGraph gr, Eq a, Eq b) => gr a b -> Property+valid_merge g = not (isEmpty g) ==> check_merge <$> elements (nodes g)+  where+    -- Using equal here rather than requiring an Eq instance.+    check_merge n = maybe False (equal g . (&g')) mc+      where+        (mc, g') = match n g++-- | Applying a mapping over contexts shouldn't actually change the+--   structure of the graph.+--+--   Note that 'nmap', 'emap' and 'nemap' are specialised versions of+--   'gmap' and thus this property also covers those.+gmap_id :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool+gmap_id g = equal (gmap id g) g++-- | 'insNode' inserts a single node and doesn't add or delete any+--   edges.+--+--   This is technically also tested using 'valid_insEdge'.+--+--   Note that we specifically use 'newNodes' to test this, as the+--   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++-- | Insert a node for every label in the list, but don't add any new+--   edges.+--+--   Note that we specifically use 'newNodes' to test this, as the+--   current behaviour is to throw an error if an existing node is+--   used.+valid_insNodes :: (DynGraph gr, Ord a, Ord b) => gr a b -> [a] -> Bool+valid_insNodes g as = all (`gelem`g') ns+                      && sort (labNodes g') == sort (lns ++ labNodes g)+                      && sort (labEdges g') == sort (labEdges g)+  where+    c = length as++    ns = newNodes c g+    lns = zip ns as++    g' = insNodes lns g++-- | Test inserting an edge.  This could possibly be a multiple edge+--   or loop.+valid_insEdge :: (DynGraph gr, Ord a, Ord b) => gr a b -> b -> Property+valid_insEdge g b = not (isEmpty g) ==>+                    do v <- pickN+                       w <- pickN+                       let el = (v,w,b)+                           g' = insEdge el g+                       return ( sort (labEdges g') == sort (el : labEdges g)+                                && sort (labNodes g') == sort (labNodes g))++  where+    pickN = elements (nodes g)++-- | Insert an edge for every label in the list.  Multiple edges and+--   loops allowed.+valid_insEdges :: (DynGraph gr, Ord a, Ord b) => gr a b -> [b] -> Property+valid_insEdges g bs = not (isEmpty g) ==>+                      do es <- mapM toLE bs+                         let g' = insEdges es g+                         return ( sort (labEdges g') == sort (es ++ labEdges g)+                                  && sort (labNodes g') == sort (labNodes g))+  where+    pickN = elements (nodes g)++    toLE b = do v <- pickN+                w <- pickN+                return (v,w,b)++-- | Explicitly test adding multiple edges.+valid_insEdges_multiple :: (DynGraph gr, Ord b) => gr a b -> b -> NonNegative Int+                           -> Property+valid_insEdges_multiple g b (NonNegative c) = not (isEmpty g) ==>+                                              do v <- pickN+                                                 w <- pickN+                                                 let bes = replicate c (v,w,b)+                                                     g' = insEdges bes g+                                                     es' = bes ++ es+                                                 return $ sort (labEdges g') == sort es'+  where+    pickN = elements (nodes g)++    es = labEdges g++-- | Delete a node, and ensure there are no edges+--   referencing that node afterwards.+valid_delNode :: (DynGraph gr) => gr a b -> Node -> Bool+valid_delNode g v = not (gelem v g')+                    && (v `S.notMember` S.fromList (esToNs (labEdges g')))+  where+    g' = delNode v g++-- | Test deleting a sub-set of nodes.+valid_delNodes :: (DynGraph gr) => gr a b -> [Node] -> Bool+valid_delNodes g vs = all (liftA2 (&&) (not . (`gelem` g')) (`S.notMember` ens)) vs+  where+    g' = delNodes vs g+    ens = S.fromList (esToNs (labEdges g'))++-- | Delete an edge, and ensure that the nodes from that+--   edge are still there (if that edge was present in the graph to+--   start with).+valid_delEdge :: (DynGraph gr) => gr a b -> (Node,Node) -> Bool+valid_delEdge g e@(v,w) = notElem e (edges g')+                          && ifOrig v+                          && ifOrig w+  where+    g' = delEdge e g++    ifOrig n = not (n `gelem` g) || (n `gelem` g')++-- | Test deleting multiple edges.+valid_delEdges :: (DynGraph gr) => gr a b -> [Edge] -> Bool+valid_delEdges g es = all check_E es+  where+    origEs = S.fromList (edges g)++    g' = delEdges es g++    newEs = S.fromList (edges g')++    check_E e@(v,w) = (e `S.notMember` origEs)+                      || ( (e `S.notMember` newEs)+                           && (v `gelem` g')+                           && (w `gelem` g')+                         )++-- | Add a 'LEdge' then delete it; the resulting graph should be the+--   same as the original graph.+valid_delLEdge :: (DynGraph gr, Eq a, Eq b) => gr a b -> b -> Property+valid_delLEdge g b = not (isEmpty g) ==>+                     do v <- pickN+                        w <- pickN+                        let le = (v,w,b)+                            g' = insEdge le g+                            g'' = delLEdge le g'+                        return (equal g g'')+  where+    pickN = elements (nodes g)++-- | Test deleting all labelled edges equal to the specified one, by+--   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'++-- | There is a version of 'mkGraph' in its documentation that uses+--   'DynGraph' (hence why it isn't used by default).  This ensures+--   that the optimised variants match this \"default\" definition.+valid_mkGraph :: (DynGraph gr, Eq a, Eq b) => Proxy (gr a b)+                 -> GraphNodesEdges a b -> Bool+valid_mkGraph p (GNEs ns es) = equal mkGr (mkGraph ns es)+  where+    mkGr = (insEdges es . insNodes ns) empty `asProxyTypeOf` p++-- | 'buildGr' re-creates the original graph after 'ufold' obtains all+--   the contexts.+valid_buildGr :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool+valid_buildGr g = equal g (buildGr cs)+  where+    cs = ufold (:) [] g++-- | Tests `gfiltermap` with a function accepting all contexts.+gfiltermap_id :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool+gfiltermap_id g = equal (gfiltermap Just g) g++-- | Tests `nfilter` with a function accepting all nodes.+nfilter_true :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool+nfilter_true g = equal (nfilter (const True) g) g++-- | Tests `labnfilter` with a function accepting all nodes.+labnfilter_true :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool+labnfilter_true g = equal (labnfilter (const True) g) g++-- | Tests `labnfilter` with a function accepting all nodes.+labfilter_true :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool+labfilter_true g = equal (labfilter (const True) g) g++-- | The subgraph induced by a list of nodes should contain exactly+-- the nodes from this list, as well as all edges between these nodes.+valid_subgraph :: (DynGraph gr, Ord b) => gr a b -> Gen Bool+valid_subgraph gr = do+  vs <- sublistOf $ nodes gr+  let sg = subgraph vs gr+      svs = S.fromList vs+      subedges = filter (\(v,w,_) -> v `S.member` svs && w `S.member` svs) $ labEdges gr+  return $ sort (nodes sg) == sort vs && sort (labEdges sg) == sort subedges++-- -----------------------------------------------------------------------------+-- Miscellaneous++-- | Ensure the edge projection functions work as intended.+edge_projections :: (Eq b) => LEdge b -> Bool+edge_projections le = le == toLEdge (toEdge le) (edgeLabel le)++-- -----------------------------------------------------------------------------++esToNs :: [LEdge b] -> [Node]+esToNs = uniqBy id . concatMap (\(v,w,_) -> [v,w])++uniqBy :: (Ord b) => (a -> b) -> [a] -> [a]+uniqBy f = map head . groupBy ((==) `on` f) . sortOn f++sortOn :: (Ord b) => (a -> b) -> [a] -> [a]+sortOn f = sortBy (compare `on` f)++-- | As with suc', but also remove any loops+sucC :: Context a b -> [Node]+sucC c = filter (/= node' c) (suc' c)++-- | As with pre', but also remove any loops+preC :: Context a b -> [Node]+preC c = filter (/= node' c) (pre' c)++-- In case a Context is produced with the Adj lists in different+-- orders, sort them so that they can then be equality tested.+sortContext :: (Ord b) => Context a b -> Context a b+sortContext (p,v,l,s) = (sort p, v, l, sort s)

@@ -0,0 +1,45 @@+{- |+   Module      : Data.Graph.Inductive.Proxy+   Description : Proxy type for graph tests+   Copyright   : (c) Ivan Lazar Miljenovic+   License     : BSD3+   Maintainer  : Ivan.Miljenovic@gmail.com++   To avoid relying upon a newer version of base, this defines a+   custom Proxy type and convenience functions.++ -}+module Data.Graph.Inductive.Proxy where++import qualified Data.Graph.Inductive.PatriciaTree as P+import qualified Data.Graph.Inductive.Tree         as T++import Data.Word (Word8)++-- -----------------------------------------------------------------------------++-- By default, we want to avoid using 'Int' to avoid clashing with the+-- 'Node' type.  Don't want to use a floating type in case of+-- potential Eq problems.+type GraphType gr = gr Char Word8++type GraphProxy gr = Proxy (GraphType gr)++type TreeP = GraphProxy T.Gr++type PatriciaTreeP = GraphProxy P.Gr++-- Not using the Data.Proxy module so this also works with older+-- versions of GHC.++data Proxy a = Proxy+  deriving (Eq, Ord, Show, Read)++asProxyTypeOf :: a -> Proxy a -> a+asProxyTypeOf a _ = a++withProxy :: Proxy a -> a -> a+withProxy _ a = a++asProxyGraphTypeOf :: gr () () -> Proxy (gr a b) -> gr () ()+asProxyGraphTypeOf gr _ = gr

@@ -0,0 +1,346 @@+{-# LANGUAGE CPP, FlexibleContexts #-}++{- |+   Module      : Data.Graph.Inductive.Query.Properties+   Description : Properties for Query modules+   Copyright   : (c) Ivan Lazar Miljenovic+   License     : BSD3+   Maintainer  : Ivan.Miljenovic@gmail.com++Rather than having an individual module of properties for each+`Data.Graph.Inductive.Query.*` module, this combines all such+properties and tests into one module.++ -}+module Data.Graph.Inductive.Query.Properties where++import Data.Graph.Inductive.Arbitrary+import Data.Graph.Inductive.Example      (clr595, vor)+import Data.Graph.Inductive.Graph+import Data.Graph.Inductive.PatriciaTree (Gr)+import Data.Graph.Inductive.Proxy+import Data.Graph.Inductive.Query++import Test.Hspec      (Spec, describe, it, shouldBe, shouldMatchList,+                        shouldSatisfy)+import Test.QuickCheck++import           Control.Arrow (second)+import           Data.List     (delete, sort, unfoldr)+import qualified Data.Set      as S++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<*>))+#endif++{-# ANN module "HLint: ignore Use camelCase" #-}++-- -----------------------------------------------------------------------------+-- Articulation Points++-- | Deleting the articulation points should increase the number of+--   components.+test_ap :: (ArbGraph gr) => Proxy (gr a b) -> Undirected gr a b -> Property+test_ap _ ug = not (isEmpty g) ==>+                 null points || noComponents (delNodes points g) > noComponents g+  where+    g = toBaseGraph ug++    points = ap g++-- -----------------------------------------------------------------------------+-- BCC++-- | Test that the bi-connected components are indeed composed solely+--   from the original graph (and comprise the entire original graph).+test_bcc :: (ArbGraph gr, Ord b) => Proxy (gr a b) -> UConnected gr a b -> Bool+test_bcc _ cg = sort (concatMap labEdges bgs) == sort (labEdges g)+                                    -- Don't test labNodes as a node+                                    -- may be repeated in multiple+                                    -- bi-connected components.+  where+    g = connGraph cg++    bgs = bcc g++-- -----------------------------------------------------------------------------+-- BFS++test_bfs :: (ArbGraph gr) => Proxy (gr a b) -> UConnected gr a b -> Bool+test_bfs _ cg = sort (bfs (connNode cg) g) == sort (nodes g)+  where+    g = connGraph cg++test_level :: (ArbGraph gr) => Proxy (gr a b) -> UConnected gr a b -> Bool+test_level _ cg = sort expect == sort (level cn g)+  where+    g = connGraph cg++    cn = connNode cg++    vs = delete cn (nodes g)++    expect = (cn,0) : map (flip (,) 1) vs++-- esp tested as part of test_sp++-- -----------------------------------------------------------------------------+-- DFS++-- TODO: flesh out++-- | The 'components' function should never return an empty list, and+--   none of its sub-lists should be empty (unless the graph is+--   empty).  All nodes in the graph should be in precisely one of the+--   components.+test_components :: (ArbGraph gr) => Proxy (gr a b) -> UConnected gr a b -> Bool+test_components _ cg = all (not . null) cs && sort (concat cs) == sort (nodes g)+  where+    g = connGraph cg++    cs = components g++-- | The strongly connected components should be a partitioning of the+--   nodes of a graph.+test_scc :: (Graph gr) => Proxy (gr a b) -> gr a b -> Bool+test_scc _ g = sort (concat (scc g)) == sort (nodes g)++-- | Every node in an undirected connected graph should be reachable.+test_reachable :: (ArbGraph gr) => Proxy (gr a b) -> UConnected gr a b -> Property+test_reachable _ cg = not (isEmpty g) ==> sort (reachable v g) == sort (nodes g)+  where+    g = connGraph cg++    v = node' . fst . matchAny $ g++-- | The nodes of the condensation should be exactly the connected+-- components, and the edges of the condensation should correspond+-- exactly to the edges between the connected components.+test_condensation :: (Graph gr) => Proxy (gr a b) -> gr a b -> Bool+test_condensation _ g = sort sccs == sort (map snd $ labNodes cdg)+                        && and [ or [ hasEdge g (v,w) == hasEdge cdg (cv,cw)+                                    | v <- sccv, w <- sccw ]+                               | (cv,sccv) <- labNodes cdg+                               , (cw,sccw) <- labNodes cdg+                               , cv /= cw+                               ]+  where+    sccs = scc g+    cdg = condensation g++-- -----------------------------------------------------------------------------+-- 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])+                                            ]+  where+    sortIt = map (second sort)++test_iDom :: Spec+test_iDom = it "iDom" $+  iDom domGraph 1 `shouldMatchList` [(2,1),(3,2),(4,2),(5,2),(6,2)]++-- Taken from <https://en.wikipedia.org/wiki/Dominator_%28graph_theory%29>+domGraph :: Gr () ()+domGraph = mkUGraph [1..6]+                    [ (1,2)+                    , (2,3)+                    , (2,4)+                    , (2,6)+                    , (3,5)+                    , (4,5)+                    , (5,2)+                    ]++-- -----------------------------------------------------------------------------+-- GVD++test_voronoiSet :: Spec+test_voronoiSet = describe "voronoiSet" $ do+  describe "inwards" $ do+    it "with root node" (voronoiSet 4 vd `shouldMatchList` [1,2,4])+    it "other node"     (voronoiSet 1 vd `shouldSatisfy`   null)+  describe "outwards" $ do+    it "with root node" (voronoiSet 4 vd0 `shouldMatchList` [2,4,6,7])+    it "other node"     (voronoiSet 1 vd0 `shouldSatisfy`   null)++test_nearestNode :: Spec+test_nearestNode = describe "nearestNode" $ do+  describe "inwards" $ do+    it "reachable"   (nearestNode 6 vd `shouldBe` Just 5)+    it "unreachable" (nearestNode 7 vd `shouldBe` Nothing)+  describe "outwards" $ do+    it "reachable"   (nearestNode 6 vd0 `shouldBe` Just 4)+    it "unreachable" (nearestNode 1 vd0 `shouldBe` Nothing)++test_nearestDist :: Spec+test_nearestDist = describe "nearestDist" $ do+  describe "inwards" $ do+    it "root"        (nearestDist 4 vd `shouldBe` Just 0)+    it "reachable"   (nearestDist 1 vd `shouldBe` Just 3)+    it "unreachable" (nearestDist 7 vd `shouldBe` Nothing)+  describe "outwards" $ do+    it "root"        (nearestDist 5 vd0 `shouldBe` Just 0)+    it "reachable"   (nearestDist 7 vd0 `shouldBe` Just 4)+    it "unreachable" (nearestDist 1 vd0 `shouldBe` Nothing)++test_nearestPath :: Spec+test_nearestPath = describe "nearestPath" $ do+  describe "inwards" $ do+    it "reachable"   (nearestPath 1 vd `shouldBe` Just [1,4])+    it "unreachable" (nearestPath 7 vd `shouldBe` Nothing)+  describe "outwards" $ do+    it "reachable"   (nearestPath 7 vd0 `shouldBe` Just [7,6,4])+    it "unreachable" (nearestPath 1 vd0 `shouldBe` Nothing)++vd :: Voronoi Int+vd = gvdIn [4,5] vor++vd0 :: Voronoi Int+vd0 = gvdOut [4,5] vor++-- -----------------------------------------------------------------------------+-- Indep++-- TODO: how to prove that the found independent set is /maximal/?++-- | Make sure the size of independent sets is indeed accurate.+test_indepSize :: (ArbGraph gr) => Proxy (gr a b) -> gr a b -> Bool+test_indepSize _ ag = uncurry ((==) . length) (indepSize g)+  where+    g = toBaseGraph ag++-- | Is this really an independent set?+test_indep :: (ArbGraph gr) => Proxy (gr a b) -> gr a b -> Bool+test_indep _ ag = and . unfoldr checkSet . S.fromList $ indep g+  where+    g = toBaseGraph ag++    checkSet = fmap checkVal . S.minView++    checkVal (v,ws) = (S.null (S.fromList (neighbors g v) `S.intersection` ws), ws)++-- -----------------------------------------------------------------------------+-- MaxFlow2++-- As it is difficult to generate a suitable arbitrary graph for which+-- there /is/ a valid flow, we instead use unit tests based upon the+-- examples in the source code.++-- | Maximum flow of 2000+exampleNetwork1 :: Network+exampleNetwork1 = emap (flip (,) 0 . fromIntegral) exampleFlowGraph1++-- | Taken from "Introduction to Algorithms" (Cormen, Leiserson, Rivest).+--   This network has a maximum flow of 23+exampleNetwork2 :: Network+-- Names of nodes in "Introduction to Algorithms":+-- 1: s+-- 2: v1+-- 3: v2+-- 4: v3+-- 5: v4+-- 6: t+exampleNetwork2 = nemap (const ()) (flip (,) 0 . fromIntegral) clr595++clr595_network :: Network+clr595_network = maxFlowgraph clr595' 1 6+  where+    clr595' = nemap (const ()) fromIntegral clr595++test_maxFlow2_with :: String -> (Network -> Node -> Node -> (Network,Double)) -> Spec+test_maxFlow2_with nm f = it nm $ do+  snd (f exampleNetwork1 1 4) `shouldBe` 2000+  snd (f exampleNetwork2 1 6) `shouldBe` 23++test_maxFlow2 :: Spec+test_maxFlow2 = describe "MaxFlow2" $ do+  test_maxFlow2_with "ekSimple" ekSimple+  test_maxFlow2_with "ekFused"  ekFused+  test_maxFlow2_with "ekList"   ekList++-- -----------------------------------------------------------------------------+-- MaxFlow++-- TODO: test other exported functions.++exampleFlowGraph1 :: Gr () Int+exampleFlowGraph1 = mkGraph [ (1,()), (2,()), (3,()), (4,()) ]+                            [ (1,2,1000), (1,3,1000)+                            , (2,3,1), (2,4,1000), (3,4,1000)+                            ]++test_maxFlow :: Spec+test_maxFlow = it "maxFlow" $ do+  maxFlow exampleFlowGraph1 1 4 `shouldBe` 2000+  maxFlow clr595            1 6 `shouldBe` 23++-- -----------------------------------------------------------------------------+-- MST++-- | A minimum spanning tree of a connected, undirected graph should+--   cover all nodes, and all edges in the tree should be present in+--   the original graph.+test_msTree :: (ArbGraph gr) => Proxy (gr a b) -> UConnected gr () Int -> Bool+test_msTree _ cg = ns == mstNs && S.isSubsetOf mstEs es+  where+    g = connGraph cg -- a Connected graph is always non-empty++    mst = map unLPath (msTree g)++    ns = S.fromList (nodes g)+    es = S.fromList (labEdges g)++    mstNs = S.unions (map (S.fromList . map fst) mst)+    mstEs = S.unions (map (S.fromList . (zipWith toE <*> tail)) mst)++    toE (w,l) (v,_) = (v,w,l)++-- -----------------------------------------------------------------------------+-- SP++test_sp :: (ArbGraph gr) => Proxy (gr a b) -> UConnected gr () (Positive Int) -> Bool+test_sp _ cg = all test_p (map unLPath (msTree g))+  where+    -- Use Positive to avoid problems with distances containing+    -- negative lengths.+    g = emap getPositive (connGraph cg)++    gCon = emap (const 1) g `asTypeOf` g++    test_p p = length p >= len_gCon                 -- Length-based test+               && length (esp v w gCon) == len_gCon+               && sum (map snd p) >= spLength v w g -- Weighting-based test+      where+        v = fst (head p)+        w = fst (last p)++        len_gCon = length (sp v w gCon)++-- -----------------------------------------------------------------------------+-- TransClos++test_trc :: (ArbGraph gr, Eq (BaseGraph gr a ())) => Proxy (gr a b)+                                                  -> UConnected (SimpleGraph gr) a ()+                                                  -> Bool+test_trc _ cg = gReach == trc g+  where+    g = connGraph cg++    lns = labNodes g++    gReach = (`asTypeOf` g)+             . insEdges [(v,w,()) | (v,_) <- lns, (w,_) <- lns]+             $ mkGraph lns []++-- -----------------------------------------------------------------------------+-- Utility functions++type UConnected gr a b = Connected (Undirected gr) a b

@@ -0,0 +1,129 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}++{- |+   Module      : TestSuite+   Description : fgl test suite+   Copyright   : (c) Ivan Lazar Miljenovic+   License     : BSD3+   Maintainer  : Ivan.Miljenovic@gmail.com++++ -}+module Main where++import Data.Graph.Inductive.Arbitrary        ()+import Data.Graph.Inductive.Graph+import Data.Graph.Inductive.Graph.Properties+import Data.Graph.Inductive.Proxy+import Data.Graph.Inductive.Query.Properties++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck       (Arbitrary, Testable)++-- -----------------------------------------------------------------------------++main :: IO ()+main = hspec $ do+  graphTests "Tree Graphs"         (Proxy :: TreeP)+  graphTests "PatriciaTree Graphs" (Proxy :: PatriciaTreeP)+  queryTests+  describe "Miscellaneous" $+    prop "edge projections" (edge_projections :: LEdge Char -> Bool)++-- -----------------------------------------------------------------------------++-- | Run all available tests on the specified graph type.  Requires+--   multiple edges and loops to be permissible.+graphTests :: forall gr. (DynGraph gr, Eq (GraphType gr), Arbitrary (GraphType gr), Show (GraphType gr))+               => String -> GraphProxy gr -> Spec+graphTests nm p = describe nm $ do+  describe "Static tests" $ do+    propType  "Eq instance"     valid_Eq+    propType  "node count"      valid_node_count+    propType  "nodeRange"       valid_nodeRange+    proxyProp "mkGraph (nodes)" valid_mkGraph_nodes+    proxyProp "mkGraph (edges)" valid_mkGraph_edges+    proxyProp "mkGraph (order)" valid_mkGraph_order+    propType  "match"           valid_match+    propType  "matchAny"        valid_matchAny+    propType  "newNodes"        newNodes_really_new+    propType  "ufold (nodes)"   ufold_all_nodes+    propType  "gelem"           all_nodes_gelem+    propType  "gelem vs nodes"  gelem_in_nodes+    propType  "hasNeighborAdj"  valid_hasNeighborAdj+    propType  "hasNeighbor"     valid_hasNeighbor+    propType  "hasLEdge"        valid_hasLEdge++  describe "Dynamic tests" $ do+    propType  "merging (&)"       valid_merge+    propType  "gmap (id)"         gmap_id+    propType  "insNode"           valid_insNode+    propType  "insNodes"          valid_insNodes+    propType  "insEdge"           valid_insEdge+    propType  "insEdges"          valid_insEdges+    propType  "insEdges (mult)"   valid_insEdges_multiple+    propType  "delNode"           valid_delNode+    propType  "delNodes"          valid_delNodes+    propType  "delEdge"           valid_delEdge+    propType  "delEdges"          valid_delEdges+    propType  "delLEdge"          valid_delLEdge+    propType  "delAllLEdge"       valid_delAllLEdge+    proxyProp "valid_mkGraph"     valid_mkGraph+    propType  "valid_buildGr"     valid_buildGr+    propType  "gfiltermap (id)"   gfiltermap_id+    propType  "nfilter (true)"    nfilter_true+    propType  "labnfilter (true)" labnfilter_true+    propType  "labfilter (true)"  labfilter_true+    propType  "subgraph"          valid_subgraph++  where+    proxyProp str = prop str . ($p)++    propType :: (Testable pr) => String -> (GraphType gr -> pr) -> Spec+    propType = prop++-- -----------------------------------------------------------------------------++-- | Run all available tests for query functions.  Only tested with+--   one graph data structure, as it is assumed that any functions+--   used by a query function are adequately tested with 'graphTests'.+queryTests :: Spec+queryTests = describe "Queries" $ do+  propP   "ap"         test_ap+  propP   "bcc"        test_bcc+  describe "BFS" $ do+    propP "bfs"        test_bfs+    propP "level"      test_level+  describe "DFS" $ do+    propP "components"   test_components+    propP "scc"          test_scc+    propP "reachable"    test_reachable+    propP "condensation" test_condensation+  describe "Dominators" $ do+    test_dom+    test_iDom+  describe "GVD" $ do+    test_voronoiSet+    test_nearestNode+    test_nearestDist+    test_nearestPath+  describe "Indep"  . keepSmall $ do+    -- Due to exponential behaviour of indep, limit the maximum size.+    propP  "indepSize" test_indepSize+    propP  "indep"     test_indep+  test_maxFlow2+  test_maxFlow+  propP "msTree"       test_msTree+  propP "sp"           test_sp+  keepSmall $+    -- Just producing the sample graph to compare against is O(|V|^2)+    propP "trc"        test_trc+  where+    propP str = prop str . ($p)++    p :: PatriciaTreeP+    p = Proxy++    keepSmall = modifyMaxSize (min 30)