packages feed

fgl 5.4.2.3 → 5.8.3.1

raw patch · 39 files changed

Files

+ ChangeLog view
@@ -0,0 +1,391 @@+5.8.3.1+-------++* Support QuickCheck 2.17.++* Removed HLint ANN pragmas.++5.8.3.0+-------++* Data.Graph.Inductive.NodeMap now has functions mkLookupNode,+  insMapLookupNode, memberNode, and lookupNode for detecting whether a+  graph already contains a node (issue #72, PR #77).++5.8.2.0+-------++* Data.Graph.Inductive.Graph now only requires Graph, not DynGraph+  (issue #100).++* Documented that some functions are partial (issue #98).++* Add `insert` function as synonym for `&` (issue #90).++5.8.1.1+-------++* Data.Graph.Inductive.Query.Dominators.{dom,iDom} could fail for some+  graphs (issue #109, regression in 5.8.1.0).++5.8.1.0+-------++* Data.Graph.Inductive.PatriciaTree.Gr and+  Data.Graph.Inductive.Tree.Gr now have Functor instances.++* 'Gr a' is now an instance of Functor.++5.8.0.0+-------++* Breaking change: MonadFail is no longer a superclass of GraphM.+  This is to support GHC 9.4.  This has no effect on the IO and ST+  instances of GraphM, but may affect users.++5.7.0.3+-------++* Bump QuickCheck dependency++5.7.0.2+-------++* Bump dependencies.++5.7.0.1+-------++* Accidentally released the wrong version.++5.7.0.0+-------++* Updating the GraphM class to be compatible with the MonadFail proposal and GHC's+  MonadFailDesugaring language extension which is enabled by default by GHC-8.6.1.++5.6.0.0+-------++* The previous version should have been a major version bump due to+  the API change.++5.5.4.0+-------++* Improved type safety of shortest-path functions (in+  `Data.Graph.Inductive.Query.SP`) thanks to Nathan Collins.++    - `getDistance`, `spLength` and `sp` now return `Maybe` values.++* Fixed building on GHC < 7.4; previously uncaught due to+  cabal-install doing the wrong thing on Travis-CI.+++5.5.3.1+-------++* Hopefully clearer documentation for `&`, `Context` and the+  `ufold`-based functions.++* Thanks to David Feuer, the existing benchmark suite is now runnable+  with `cabal bench`.++* Some performance improvements for `PatriciaTree`, thanks to David+  Feuer.++5.5.3.0+-------++* Additional closure functions by Matthew Danish.++* `Bifunctor` instances for base >= 4.8.0.0.++* An `ST`-based `GraphM` instance.++* Addition of `order` and `size` functions for finding the number of+  nodes and edges respectively in a graph (the former is an alias for+  the existing `noNodes` function).++* The rules for faster implementations of `insNode` and `insEdge` for+  `PatriciaTree` should fire more often now.++5.5.2.3+-------++* Earlier fix for `NFData` wasn't quite complete/correct.++5.5.2.2+-------++* Ensure firing of specialised rules for `PatriciaTree`.++* Better way of only creating `NFData` instances when possible.++5.5.2.1+-------++* Only create `NFData` instances for GHC >= 7.4.1.++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+-------++* Support added for GHC 7.10 by Herbert Valerio Riedel.++* Additional DFS query functions added by Conrad Parker.++* Repository location changed to GitHub.++* Code cleanup:++    - Replaced usage of internal FiniteMap copy with Data.Map and+      Data.Set from the containers library.++    - Remove usage of data type contexts.++    - Use newtypes where applicable.++5.5.0.1+-------++* Fix up Eq instances for Tree and PatriciaTree so that they work with+  multiple edges.++5.5.0.0+-------++* Add proper Show, Read and Eq instances to Data.Graph.Inductive.Tree+  and Data.Graph.Inductive.PatriciaTree.++* Add pretty-printing functions to Data.Graph.Inductive.Graph.  These+  are based upon the old Show implementation for+  Data.Graph.Inductive.Tree.++* Now use PatriciaTree by default rather than Tree (and recommend as+  such).  IntMap has been receiving a lot of optimisation work on it,+  whereas the internal FiniteMap implementation hasn't received any+  attention.++* The `version :: IO ()` action now uses the actual Cabal version.++* Remove Data.Graph.Inductive.Graphviz; use the graphviz package+  instead.++5.4.2.4+-------++* Update to work with GHC-7.2 and Cabal-1.6.++5.4.2.3+-------++* Maintainership taken over by Ivan Miljenovic.++* 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
Data/Graph/Inductive.hs view
@@ -1,33 +1,29 @@ ---------------------------------------------------------------------------------  ---  Inductive.hs -- Functional Graph Library   --+--  Inductive.hs -- Functional Graph Library+-- --  (c) 1999-2007 by Martin Erwig [see file COPYRIGHT] -- ------------------------------------------------------------------------------ -module Data.Graph.Inductive(-    module Data.Graph.Inductive.Graph,-    module Data.Graph.Inductive.Tree,-    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.Graphviz,-    module Data.Graph.Inductive.NodeMap,+module Data.Graph.Inductive+  ( module I     -- * Version Information-    version-) where+  , version+  ) where -import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Tree-import Data.Graph.Inductive.Basic-import Data.Graph.Inductive.Monad-import Data.Graph.Inductive.Monad.IOArray-import Data.Graph.Inductive.Query-import Data.Graph.Inductive.Graphviz-import Data.Graph.Inductive.NodeMap+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)+ -- | Version info version :: IO ()-version = putStrLn "\nFGL - Functional Graph Library, April 2007"+version = putStrLn $ "\nFGL - Functional Graph Library, version "+                      ++ showVersion Paths.version
Data/Graph/Inductive/Basic.hs view
@@ -12,18 +12,19 @@     hasLoop,isSimple,     -- * Tree Operations     postorder, postorderF, preorder, preorderF-) +) where   import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Internal.Thread (threadMaybe,threadList)+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,38 +70,44 @@ --  -- | '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) -> +-- gfold :: ((Context a b) -> [Node]) -> ((Node,a) -> c -> d) -> --          (Maybe d -> c -> c) -> c -> [Node] -> Graph a b -> c -- gfold f d b u l g = fst (gfoldn f d b u l g)  -- type Dir a b    = (Context a b) -> [Node]  -- direction of fold -- type Dagg a b c = (Node,a) -> b -> c       -- depth aggregation -- type Bagg a b   = (Maybe a -> b -> b,b)    -- breadth/level aggregation--- +-- -- gfold :: (Dir a b) -> (Dagg a c d) -> (Bagg d c) -> [Node] -> Graph a b -> c -- 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-		    -> (Maybe d -> c -> c, c)	    -- ^ breadth\/level aggregation-		    -> [Node]-		    -> gr a b-		    -> c+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+        -> c gfold f d b l g = fst (gfoldn f d b l g)  -- not finished yet ...
Data/Graph/Inductive/Example.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE MultiParamTypeClasses #-}+ -- | Example Graphs module Data.Graph.Inductive.Example(     -- * Auxiliary Functions@@ -19,9 +21,9 @@     clr479', clr489', clr486', clr508', clr528', kin248', vor' )where +import Data.Graph.Inductive.Graph+import Data.Graph.Inductive.PatriciaTree -import Data.Graph.Inductive-import Data.Graph.Inductive.Tree import Data.Graph.Inductive.Monad import Data.Graph.Inductive.Monad.IOArray @@ -30,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@@ -39,7 +41,7 @@  -- | empty (unlabeled) edge list noEdges :: [UEdge]-noEdges = [] +noEdges = []   a,b,c,e,loop,ab,abb,dag3   :: Gr Char ()@@ -52,7 +54,7 @@ b    = mkGraph (zip [1..2] "ab") noEdges      -- just two nodes c    = mkGraph (zip [1..3] "abc") noEdges     -- just three nodes e    = ([((),1)],2,'b',[]) & a                -- just one edge a-->b-e3   = mkGraph (genUNodes 2) +e3   = mkGraph (genUNodes 2)        [(1,2,"a"),(1,2,"b"),(1,2,"a")]        -- three edges (two labels) a-->b loop = ([],1,'a',[((),1)]) & empty            -- loop on single node ab   = ([((),1)],2,'b',[((),1)]) & a          -- cycle of two nodes:  a<-->b@@ -67,7 +69,7 @@ dag4 = mkGraph (genLNodes 1 4) (labUEdges [(1,2),(1,4),(2,3),(2,4),(4,3)])  d1   = mkGraph (genLNodes 1 2) [(1,2,1)]-d3   = mkGraph (genLNodes 1 3) [(1,2,1),(1,3,4),(2,3,2)] +d3   = mkGraph (genLNodes 1 3) [(1,2,1),(1,3,4),(2,3,2)]  g3 = ([("left",2),("up",3)],1,'a',[("right",2)]) & (                         ([],2,'b',[("down",3)])  & (@@ -86,10 +88,10 @@ b'    = mkGraphM (zip [1..2] "ab") noEdges      -- just two nodes c'    = mkGraphM (zip [1..3] "abc") noEdges     -- just three nodes e'    = mkGraphM (zip [1..2] "ab") [(1,2,())]   -- just one edge a-->b-e3'   = mkGraphM (genUNodes 2) +e3'   = mkGraphM (genUNodes 2)           [(1,2,"a"),(1,2,"b"),(1,2,"a")]       -- three edges (two labels) a-->b loop' = mkGraphM [(1,'a')] [(1,1,())]           -- loop on single node-ab'   = mkGraphM (zip [1..2] "ab") +ab'   = mkGraphM (zip [1..2] "ab")           [(1,2,()),(2,1,())]                   -- cycle of two nodes:  a<-->b abb'  = mkGraphM (zip [1..2] "ab") (labUEdges [(2,2)]) -- a and loop on b @@ -97,20 +99,20 @@ dag4' = mkGraphM (genLNodes 1 4) (labUEdges [(1,2),(1,4),(2,3),(2,4),(4,3)])  d1'   = mkGraphM (genLNodes 1 2) [(1,2,1)]-d3'   = mkGraphM (genLNodes 1 3) [(1,2,1),(1,3,4),(2,3,2)] +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])  @@ -121,7 +123,7 @@ kin248           :: Gr Int () vor              :: Gr String Int -clr479 = mkGraph (genLNodes 'u' 6) +clr479 = mkGraph (genLNodes 'u' 6)          (labUEdges [(1,2),(1,4),(2,5),(3,5),(3,6),(4,2),(5,4),(6,6)]) clr486 = mkGraph (zip [1..9] ["shorts","socks","watch","pants","shoes",                               "shirt","belt","tie","jacket"])@@ -135,10 +137,10 @@ clr528 = mkGraph [(1,'s'),(2,'u'),(3,'v'),(4,'x'),(5,'y')]                  [(1,2,10),(1,4,5),(2,3,1),(2,4,2),(3,5,4),                   (4,2,3),(4,3,9),(4,5,2),(5,1,7),(5,3,6)]-clr595 = mkGraph (zip [1..6] [1..6]) +clr595 = mkGraph (zip [1..6] [1..6])                  [(1,2,16),(1,3,13),(2,3,10),(2,4,12),(3,2,4),                   (3,5,14),(4,3,9),(4,6,20),(5,4,7),(5,6,4)]-gr1    = mkGraph (zip [1..10] [1..10]) +gr1    = mkGraph (zip [1..10] [1..10])                  [(1,2,12),(1,3,1),(1,4,2),(2,3,1),(2,5,7),(2,6,5),(3,6,1),                   (3,7,7),(4,3,3),(4,6,2),(4,7,5),(5,3,2),(5,6,3),(5,8,3),                   (6,7,2),(6,8,3),(6,9,1),(7,9,9),(8,9,1),(8,10,4),(9,10,11)]@@ -160,7 +162,7 @@ kin248'          :: IO (SGr Int ()) vor'             :: IO (SGr String Int) -clr479' = mkGraphM (genLNodes 'u' 6) +clr479' = mkGraphM (genLNodes 'u' 6)           (labUEdges [(1,2),(1,4),(2,5),(3,5),(3,6),(4,2),(5,4),(6,6)]) clr486' = mkGraphM (zip [1..9] ["shorts","socks","watch","pants","shoes",                                 "shirt","belt","tie","jacket"])@@ -184,4 +186,3 @@                 [(1,4,3),(2,3,3),(2,4,3),(4,2,4),(4,6,2),                  (5,2,5),(5,3,6),(5,7,5),(5,8,6),                  (6,5,3),(6,7,2),(7,8,3),(8,7,3)]-
Data/Graph/Inductive/Graph.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-}+ -- (c) 1999-2005 by Martin Erwig [see file COPYRIGHT]--- | Static and Dynamic Inductive Graphs  +-- | Static and Dynamic Inductive Graphs module Data.Graph.Inductive.Graph (     -- * General Type Defintions     -- ** Node and Edge Types@@ -12,8 +14,8 @@     -- | We define two graph classes:     --     --   Graph: static, decomposable graphs.-    --		Static means that a graph itself cannot be changed-    --             +    --    Static means that a graph itself cannot be changed+    --     --   DynGraph: dynamic, extensible graphs.     --             Dynamic graphs inherit all operations from static graphs     --             but also offer operations to extend and change graphs.@@ -21,139 +23,98 @@     -- Each class contains in addition to its essential operations those     -- derived operations that might be overwritten by a more efficient     -- implementation in an instance definition.-    -- +    --     -- Note that labNodes is essentially needed because the default definition     -- for matchAny is based on it: we need some node from the graph to define-    -- matchAny in terms of match. Alternatively, we could have made matchAny -    -- essential and have labNodes defined in terms of ufold and matchAny. -    -- However, in general, labNodes seems to be (at least) as easy to define -    -- as matchAny. We have chosen labNodes instead of the function nodes since +    -- matchAny in terms of match. Alternatively, we could have made matchAny+    -- essential and have labNodes defined in terms of ufold and matchAny.+    -- However, in general, labNodes seems to be (at least) as easy to define+    -- as matchAny. We have chosen labNodes instead of the function nodes since     -- nodes can be easily derived from labNodes, but not vice versa.-    Graph(..), +    Graph(..),     DynGraph(..),     -- * Operations+    insert,+    order,+    size,     -- ** 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,+    -- * 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		+type  Node   = Int -- | Labeled node-type LNode a = (Node,a)		+type LNode a = (Node,a) -- | Quasi-unlabeled node-type UNode   = LNode ()		+type UNode   = LNode ()  -- | Unlabeled edge-type  Edge   = (Node,Node)	+type  Edge   = (Node,Node) -- | Labeled edge-type LEdge b = (Node,Node,b)	+type LEdge b = (Node,Node,b) -- | Quasi-unlabeled edge-type UEdge   = LEdge ()		+type UEdge   = LEdge ()  -- | Unlabeled path-type Path    = [Node]		+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]		+type UPath   = [UNode]  -- | Labeled links to or from a 'Node'. type Adj b        = [(b,Node)] -- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'.+--+--   In other words, this captures all information regarding the+--   specified 'Node' within a graph. type Context a b  = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node type MContext a b = Maybe (Context a b) -- | 'Graph' decomposition - the context removed from a 'Graph', and the rest@@ -169,183 +130,309 @@  -- | 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,_):_ ->+                   case match v g of+                     (Just c,g') -> (c,g')+                     _ -> error "Match Exception, cannot extract node"+   -- | The number of 'Node's in a 'Graph'.   noNodes   :: gr a b -> Int+  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 adjacencies should only refer to either a Node already+  --   in a graph or the node in the Context itself (for loops).+  --+  --   Behaviour is undefined if the specified 'Node' already exists+  --   in the graph.   (&) :: Context a b -> gr a b -> gr a b +-- | A synonym for '&', to avoid conflicts with the similarly named+-- operator in "Data.Function".+insert :: DynGraph gr => Context a b -> gr a b -> gr a b+insert = (&) --- | 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+-- | The number of nodes in the graph.  An alias for 'noNodes'.+order :: (Graph gr) => gr a b -> Int+order = noNodes --- | Map a function over the graph.-gmap :: DynGraph gr => (Context a b -> Context c d) -> gr a b -> gr c d+-- | The number of edges in the graph.+--+--   Note that this counts every edge found, so if you are+--   representing an unordered graph by having each edge mirrored this+--   will be incorrect.+--+--   If you created an unordered graph by either mirroring every edge+--   (including loops!) or using the @undir@ function in+--   "Data.Graph.Inductive.Basic" then you can safely halve the value+--   returned by this.+size :: (Graph gr) => gr a b -> Int+size = length . labEdges++-- | Fold a function over the graph by recursively calling 'match'.+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 by recursively calling 'match'.+gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d gmap f = ufold (\c->(f c&)) empty+{-# NOINLINE [0] gmap #-}  -- | 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))+{-# NOINLINE [0] nmap #-}  -- | 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)+{-# NOINLINE [0] emap #-} +-- | 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)+{-# NOINLINE [0] nemap #-}+ -- | 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+{-# NOINLINE [0] insEdge #-}  -- | 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 'delAllLEdge'. 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+{-# INLINABLE insNodes #-}  -- | 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+{-# INLINABLE insEdges #-}  -- | 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 vs es = mkGraph (labUNodes vs) (labUEdges es) -   where labUEdges = map (\(v,w)->(v,w,()))-         labUNodes = map (\v->(v,()))- +mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () ()+mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es)+   where+     labUEdges = map (`toLEdge` ())+     labUNodes = map (flip (,) ())++-- | Build a graph out of the contexts for which the predicate is+-- satisfied by recursively calling 'match'.+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@@ -360,15 +447,19 @@ labNode' (_,v,l,_) = (v,l)  -- | All 'Node's linked to or from in a 'Context'.-neighbors' :: Context a b -> [Node] +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'  -- | All 'Node's linked from in a 'Context'.-pre' :: Context a b -> [Node] +pre' :: Context a b -> [Node] pre' = map snd . context1l'  -- | All 'Node's linked from in a 'Context', and the label of the links.@@ -376,15 +467,15 @@ lsuc' = map flip2 . context4l'  -- | All 'Node's linked from in a 'Context', and the label of the links.-lpre' :: Context a b -> [(Node,b)] +lpre' :: Context a b -> [(Node,b)] lpre' = map flip2 . context1l'  -- | All outward-directed 'LEdge's in a 'Context'.-out' :: Context a b -> [LEdge b] +out' :: Context a b -> [LEdge b] out' c@(_,v,_,_) = map (\(l,w)->(v,w,l)) (context4l' c)  -- | All inward-directed 'LEdge's in a 'Context'.-inn' :: Context a b -> [LEdge b] +inn' :: Context a b -> [LEdge b] inn' c@(_,v,_,_) = map (\(l,w)->(w,v,l)) (context1l' c)  -- | The outward degree of a 'Context'.@@ -399,41 +490,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 +-- 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 .) .)@@ -445,14 +562,51 @@  -- 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 -context1l' :: Context a b -> Adj b +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 -context4l' :: Context a b -> Adj b +context4l' :: Context a b -> Adj b context4l' (p,v,_,s) = s++filter ((==v).snd) p++----------------------------------------------------------------------+-- PRETTY PRINTING+----------------------------------------------------------------------++-- | Pretty-print the graph.  Note that this loses a lot of+--   information, such as edge inverses, etc.+prettify :: (Graph gr, Show a, Show b) => gr a b -> String+prettify g = foldr (showsContext . context g) id (nodes g) ""+  where+    showsContext (_,n,l,s) sg = shows n . (':':) . shows l+                                . showString "->" . shows s+                                . ('\n':) . sg++-- | 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
− Data/Graph/Inductive/Graphviz.hs 
@@ -1,70 +0,0 @@--- | Simple graphviz output.-module Data.Graph.Inductive.Graphviz(-    Orient(..),-    graphviz, graphviz'-) where--import Data.Graph.Inductive.Graph--data Orient = Portrait | Landscape deriving (Eq, Show)--o2s :: Orient -> String-o2s Portrait = "\trotate = \"0\"\n"-o2s Landscape = "\trotate = \"90\"\n"---- | Formats a graph for use in graphviz.-graphviz :: (Graph g, Show a, Show b) =>    g a b   -- ^ The graph to format-					 -> String  -- ^ The title of the graph-					 -> (Double, Double)	-- ^ The size-								-- of the page-					 -> (Int, Int)	-- ^ The width and-							-- height of the page-							-- grid-					 -> Orient  -- ^ The orientation of-						    -- the graph.-					 -> String--i2d :: Int -> Double-i2d = fromInteger . toInteger--graphviz g t (w, h) p@(pw', ph') o =-    let n = labNodes g-	e = labEdges g-	ns = concatMap sn n-	es = concatMap se e-	sz w' h' = if o == Portrait then show w'++","++show h' else show h'++","++show w'-	ps = show w++","++show h-	(pw, ph) = if o == Portrait then p else (ph', pw')-	--gs = show ((w*(i2d pw))-m)++","++show ((h*(i2d ph))-m)-	gs = sz (w*(i2d pw)) (h*(i2d ph))-    in "digraph "++t++" {\n"-	    ++"\tmargin = \"0\"\n"-	    ++"\tpage = \""++ps++"\"\n"-	    ++"\tsize = \""++gs++"\"\n"-	    ++o2s o-	    ++"\tratio = \"fill\"\n"-	    ++ns-	    ++es-	++"}"-    where sn (n, a) | sa == ""	= ""-		    | otherwise	= '\t':(show n ++ sa ++ "\n")-	    where sa = sl a-	  se (n1, n2, b) = '\t':(show n1 ++ " -> " ++ show n2 ++ sl b ++ "\n")---- | Format a graph for graphviz with reasonable defaults: title of \"fgl\",--- 8.5x11 pages, one page, landscape orientation-graphviz' :: (Graph g, Show a, Show b) => g a b -> String-graphviz' g = graphviz g "fgl" (8.5,11.0) (1,1) Landscape--sq :: String -> String-sq s@[c]                     = s-sq ('"':s)  | last s == '"'  = init s-	    | otherwise	     = s-sq ('\'':s) | last s == '\'' = init s-	    | otherwise	     = s-sq s                         = s--sl :: (Show a) => a -> String-sl a =-    let l = sq (show a)-    in if (l /= "()") then (" [label = \""++l++"\"]") else ""
− Data/Graph/Inductive/Internal/FiniteMap.hs 
@@ -1,209 +0,0 @@--- | Simple Finite Maps.--- This implementation provides several useful methods that Data.FiniteMap--- does not.--module Data.Graph.Inductive.Internal.FiniteMap(-    -- * Type-    FiniteMap(..),-    -- * Operations-    emptyFM,addToFM,delFromFM,-    updFM,-    accumFM,-    splitFM,-    isEmptyFM,sizeFM,lookupFM,elemFM,-    rangeFM,-    minFM,maxFM,predFM,succFM,-    splitMinFM,-    fmToList-) where--import Data.Maybe (isJust)              --data Ord a => FiniteMap a b =-    Empty | Node Int (FiniteMap a b) (a,b) (FiniteMap a b)-    deriving (Eq)---------------------------------------------------------------------------- UTILITIES---------------------------------------------------------------------------- pretty printing----showsMap :: (Show a,Show b,Ord a) => FiniteMap a b -> ShowS-showsMap Empty            = id-showsMap (Node _ l (i,x) r) = showsMap l . (' ':) . -                              shows i . ("->"++) . shows x . showsMap r-                -instance (Show a,Show b,Ord a) => Show (FiniteMap a b) where-  showsPrec _ m = showsMap m----- other----splitMax :: Ord a => FiniteMap a b -> (FiniteMap a b,(a,b))-splitMax (Node _ l x Empty) = (l,x)-splitMax (Node _ l x r)     = (avlBalance l x m,y) where (m,y) = splitMax r-splitMax Empty		    = error "splitMax on empty FiniteMap"--merge :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b-merge l Empty = l-merge Empty r = r-merge l r     = avlBalance l' x r where (l',x) = splitMax l---------------------------------------------------------------------------- MAIN FUNCTIONS-------------------------------------------------------------------------emptyFM :: Ord a => FiniteMap a b-emptyFM  = Empty--addToFM :: Ord a => FiniteMap a b -> a -> b -> FiniteMap a b-addToFM Empty            i x              =  node Empty (i,x) Empty-addToFM (Node h l (j,y) r) i x-    | i<j        =  avlBalance (addToFM l i x) (j,y) r-    | i>j        =  avlBalance l (j,y) (addToFM r i x) -    | otherwise  =  Node h l (j,x) r  ---- | applies function to stored entry-updFM :: Ord a => FiniteMap a b -> a -> (b -> b) -> FiniteMap a b-updFM Empty              _ _              =  Empty-updFM (Node h l (j,x) r) i f -           | i<j        =  let l' = updFM l i f in l' `seq` Node h l' (j,x) r-           | i>j        =  let r' = updFM r i f in r' `seq` Node h l (j,x) r'-           | otherwise  =  Node h l (j,f x) r  ---- | defines or aggregates entries-accumFM :: Ord a => FiniteMap a b -> a -> (b -> b -> b) -> b -> FiniteMap a b-accumFM Empty              i _ x              =  node Empty (i,x) Empty-accumFM (Node h l (j,y) r) i f x -    | i<j        =  avlBalance (accumFM l i f x) (j,y) r-    | i>j        =  avlBalance l (j,y) (accumFM r i f x) -    | otherwise  =  Node h l (j,f x y) r  --delFromFM :: Ord a => FiniteMap a b -> a -> FiniteMap a b-delFromFM Empty              _              =  Empty-delFromFM (Node _ l (j,x) r) i-    | i<j        =  avlBalance (delFromFM l i) (j,x) r-    | i>j        =  avlBalance l (j,x) (delFromFM r i) -    | otherwise  =  merge l r  --isEmptyFM :: FiniteMap a b -> Bool-isEmptyFM Empty = True-isEmptyFM _     = False--sizeFM :: Ord a => FiniteMap a b -> Int-sizeFM Empty          = 0-sizeFM (Node _ l _ r) = sizeFM l + 1 + sizeFM r--lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b-lookupFM Empty _ = Nothing-lookupFM (Node _ l (j,x) r) i | i<j        =  lookupFM l i-                              | i>j        =  lookupFM r i -                              | otherwise  =  Just x---- | applies lookup to an interval-rangeFM :: Ord a => FiniteMap a b -> a -> a -> [b]-rangeFM m i j = rangeFMa m i j []----rangeFMa Empty _ _ a = a-rangeFMa (Node _ l (k,x) r) i j a-    | k<i       = rangeFMa r i j a-    | k>j       = rangeFMa l i j a-    | otherwise = rangeFMa l i j (x:rangeFMa r i j a)--minFM :: Ord a => FiniteMap a b -> Maybe (a,b)-minFM Empty              = Nothing-minFM (Node _ Empty x _) = Just x-minFM (Node _ l     _ _) = minFM l--maxFM :: Ord a => FiniteMap a b -> Maybe (a,b)-maxFM Empty              = Nothing-maxFM (Node _ _ x Empty) = Just x-maxFM (Node _ _ _ r)     = maxFM r--predFM :: Ord a => FiniteMap a b -> a -> Maybe (a,b)-predFM m i = predFM' m i Nothing----predFM' Empty              _ p              =  p-predFM' (Node _ l (j,x) r) i p | i<j        =  predFM' l i p-                               | i>j        =  predFM' r i (Just (j,x))-                               | isJust ml  =  ml -                               | otherwise  =  p-                                 where ml = maxFM l-                           -succFM :: Ord a => FiniteMap a b -> a -> Maybe (a,b)-succFM m i = succFM' m i Nothing----succFM' Empty              _ p              =  p-succFM' (Node _ l (j,x) r) i p | i<j        =  succFM' l i (Just (j,x))-                               | i>j        =  succFM' r i p-                               | isJust mr  =  mr -                               | otherwise  =  p-                                 where mr = minFM r--elemFM :: Ord a => FiniteMap a b -> a -> Bool-elemFM m i = case lookupFM m i of {Nothing -> False; _ -> True}---- | combines delFrom and lookup-splitFM :: Ord a => FiniteMap a b -> a -> Maybe (FiniteMap a b,(a,b))-splitFM Empty              _ =  Nothing-splitFM (Node _ l (j,x) r) i =-        if i<j then-           case splitFM l i of-                Just (l',y) -> Just (avlBalance l' (j,x) r,y)-                Nothing     -> Nothing  else-        if i>j then-           case splitFM r i of-                Just (r',y) -> Just (avlBalance l (j,x) r',y) -                Nothing     -> Nothing  -        else {- i==j -}        Just (merge l r,(j,x))  ---- | combines splitFM and minFM-splitMinFM :: Ord a => FiniteMap a b -> Maybe (FiniteMap a b,(a,b))-splitMinFM Empty              =  Nothing-splitMinFM (Node _ Empty x r) = Just (r,x)-splitMinFM (Node _ l x r)     = Just (avlBalance l' x r,y) -                                where Just (l',y) = splitMinFM l--fmToList :: Ord a => FiniteMap a b -> [(a,b)]-fmToList m = scan m []-             where scan Empty xs = xs-                   scan (Node _ l x r) xs = scan l (x:(scan r xs))--------------------------------------------------------------------------- AVL tree helper functions-------------------------------------------------------------------------height :: Ord a => FiniteMap a b -> Int-height Empty          = 0-height (Node h _ _ _) = h--node :: Ord a => FiniteMap a b -> (a,b) -> FiniteMap a b -> FiniteMap a b-node l val r = Node h l val r-    where h=1+(height l `max` height r)--avlBalance :: Ord a => FiniteMap a b -> (a,b) -> FiniteMap a b -> FiniteMap a b-avlBalance l (i,x) r-    | (hr + 1 < hl) && (bias l < 0) = rotr (node (rotl l) (i,x) r)-    | (hr + 1 < hl)                 = rotr (node l (i,x) r)-    | (hl + 1 < hr) && (0 < bias r) = rotl (node l (i,x) (rotr r))-    | (hl + 1 < hr)                 = rotl (node l (i,x) r)-    | otherwise                     = node l (i,x) r-    where hl=height l; hr=height r--bias :: Ord a => FiniteMap a b -> Int-bias (Node _ l _ r) = height l - height r-bias Empty	    = 0--rotr :: Ord a => FiniteMap a b -> FiniteMap a b-rotr Empty			      = Empty-rotr (Node _ (Node _ l1 v1 r1) v2 r2) = node l1 v1 (node r1 v2 r2)-rotr (Node _ Empty _ _)		      = error "rotr on invalid FiniteMap"--rotl :: Ord a => FiniteMap a b -> FiniteMap a b-rotl Empty			      = Empty-rotl (Node _ l1 v1 (Node _ l2 v2 r2)) = node (node l1 v1 l2) v2 r2-rotl (Node _ _ _ Empty)		      = error "rotl on invalid FiniteMap"
Data/Graph/Inductive/Internal/Heap.hs view
@@ -1,64 +1,81 @@+{-# LANGUAGE CPP #-}+ -- | Pairing heap implementation of dictionary 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 Text.Show (showListWith) -data Ord a => Heap a b = Empty | Node a b [Heap a b]-     deriving Eq+#if MIN_VERSION_containers (0,4,2)+import Control.DeepSeq (NFData (..))+#endif -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 (Show a,Ord a,Show b) => Show (Heap a b) where-  showsPrec _ d = showsHeap d+data Heap a b = Empty | Node a b [Heap a b]+     deriving (Eq, Show, Read) +#if MIN_VERSION_containers (0,4,2)+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+#endif +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 +85,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]
Data/Graph/Inductive/Internal/Queue.hs view
@@ -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
Data/Graph/Inductive/Internal/RootPath.hs view
@@ -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] @@ -31,21 +19,28 @@                  []   -> []                  x:_  -> x --- | Find the first path in a tree that starts with the given node+-- | Find the first path in a tree that starts with the given node.+--+--   Returns an empty list if there is no such path. 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) +getPath v = reverse . first ((==v) . head)  getLPath :: Node -> LRTree a -> LPath a getLPath v = LP . reverse . findP v -getDistance :: Node -> LRTree a -> a-getDistance v = snd . head . findP v+-- | Return the distance to the given node in the given tree.+--+--   Returns 'Nothing' if the given node is not reachable.+getDistance :: Node -> LRTree a -> Maybe a+getDistance v t = case findP v t of+  []      -> Nothing+  (_,d):_ -> Just d  getLPathNodes :: Node -> LRTree a -> Path getLPathNodes v = (\(LP p)->map fst p) . getLPath v
Data/Graph/Inductive/Internal/Thread.hs view
@@ -20,22 +20,22 @@ {- class Thread t a b where   split :: a -> t -> (b,t)-  -  ++ 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) -}  {-    Make clear different notions:-   +    "thread" = data structure + split operation    ...      = threadable data structure    ...      = split operation-   + -}  @@ -50,13 +50,13 @@  {- --  (1) simple collect in a list--- +-- foldT1' ys []     d = ys foldT1' ys (x:xs) d = foldT1' (y:ys) xs d'  where (y,d') = split x d foldT1 xs d = foldT1' [] xs d  --  (2) combine by a function--- +-- foldT2' f ys []     d = ys foldT2' f ys (x:xs) d = foldT2' f (f y ys) xs d'  where (y,d') = split x d foldT2 f u xs d = foldT2' f u xs d@@ -75,21 +75,21 @@ type Collect r c  = (r -> c -> c,c)  --  (3) abstract from split--- -threadList' :: (Collect r c) -> (Split t i r) -> [i] -> t -> (c,t)-threadList' (_,c) _ []	       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 -{-  +{-    Note: threadList' works top-down (or, from left),          whereas dfs,gfold,... have been defined bottom-up (or from right).- +    ==> 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 (_,c) _ []     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                                         (c',t'') = threadList (f,c) split is t'@@ -100,13 +100,13 @@ --     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)  threadMaybe' :: (r->a)->Split t i r->Split t j (Maybe i)->Split t j (Maybe a)-threadMaybe' f cont split j t = +threadMaybe' f cont split j t =       case mi of Just i  -> (Just (f r),t'') where (r,t'') = cont i t'                  Nothing -> (Nothing,t')       where (mi,t') = split j t@@ -117,7 +117,7 @@ --                -> e -> f -> (Maybe c,d) -- threadMaybe :: (i->r->a)->Split t i r->Split t j (Maybe i)->Split t j (Maybe a) threadMaybe :: (i -> r -> a) -> Split t i r -> SplitM t j i -> SplitM t j a-threadMaybe f cont split j t = +threadMaybe f cont split j t =       case mi of Just i  -> (Just (f i r),t'') where (r,t'') = cont i t'                  Nothing -> (Nothing,t')       where (mi,t') = split j t@@ -125,7 +125,7 @@  -- (C) compose splits in parallel (is a kind of generalized zip) ----- splitPar :: (a -> b -> (c,d)) -> (e -> f -> (g,h)) +-- splitPar :: (a -> b -> (c,d)) -> (e -> f -> (g,h)) --             -> (a,e) -> (b,f) -> ((c,g),(d,h)) splitPar :: Split t i r -> Split u j s -> Split (t,u) (i,j) (r,s) splitPar split split' (i,j) (t,u) = ((r,s),(t',u'))@@ -135,15 +135,15 @@ splitParM :: SplitM t i r -> Split u j s -> SplitM (t,u) (i,j) (r,s) splitParM splitm split (i,j) (t,u) =           case mr of Just r  -> (Just (r,s),(t',u'))-                     Nothing -> (Nothing,(t',u))   -- ignore 2nd split +                     Nothing -> (Nothing,(t',u))   -- ignore 2nd split           where (mr,t') = splitm i t                 (s,u')  = split j u   -- (D) merge a thread with/into a computation ---{- +{-    Example: assign consecutive numbers to the nodes of a tree- +    Input: type d, thread (t,split), fold operation on d -}
Data/Graph/Inductive/Monad.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE CPP, MultiParamTypeClasses #-}+ -- (c) 2002 by Martin Erwig [see file COPYRIGHT] -- | Monadic Graphs module Data.Graph.Inductive.Monad(     -- * Classes-    GraphM(..), +    GraphM(..),     -- * Operations     -- ** Graph Folds and Maps     ufoldM,@@ -18,55 +20,66 @@  import Data.Graph.Inductive.Graph - ---------------------------------------------------------------------- -- MONADIC GRAPH CLASS ---------------------------------------------------------------------- --- +-- -- Currently, we define just one monadic graph class: -- --   GraphM:    static, decomposable graphs --              static means that a graph itself cannot be changed---             +-- -- Later we might also define DynGraphM for dynamic, extensible graphs--- +--    -- 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 +  matchAnyM g = do vs <- labNodesM g                    case vs of                      []      -> error "Match Exception, Empty Graph"-                     (v,_):_ -> do (Just c,g') <- matchM v g-                                   return (c,g')  +                     (v,_):_ -> do r <- matchM v g+                                   case r of+                                     (Just c,g') -> return (c,g')+                                     _ -> error "Match Exception, cannot extract node"++  noNodesM   :: m (gr a b) -> m Int   noNodesM = labNodesM >>. length-  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 error "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)-f >>. g = (>>= return . g) . f +(>>.) :: (Monad m) => (m a -> m b) -> (b -> c) -> m a -> m c+f >>. g = (>>= return . g) . f   ----------------------------------------------------------------------@@ -74,10 +87,10 @@ ----------------------------------------------------------------------  -- graph folds and maps--- +--  -- | 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@@ -87,124 +100,130 @@  -- (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')  +delNodesM (v:vs) g = do (_,g') <- matchM v g+                        delNodesM vs (return g') -mkUGraphM :: GraphM m gr => [Node] -> [Edge] -> m (gr () ())-mkUGraphM vs es = mkGraphM (labUNodes vs) (labUEdges es) +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--- +--  -- -- context inspection--- -- +-- -- -- node' :: Context a b -> Node -- node' (_,v,_,_) = v--- +-- -- lab' :: Context a b -> a -- lab' (_,_,l,_) = l--- +-- -- labNode' :: Context a b -> LNode a -- labNode' (_,v,l,_) = (v,l)--- --- neighbors' :: Context a b -> [Node] +--+-- neighbors' :: Context a b -> [Node] -- neighbors' (p,_,_,s) = map snd p++map snd s--- +-- -- suc' :: Context a b -> [Node] -- suc' (_,_,_,s) = map snd s--- --- pre' :: Context a b -> [Node] +--+-- pre' :: Context a b -> [Node] -- pre' (p,_,_,_) = map snd p--- --- lpre' :: Context a b -> [(Node,b)] +--+-- lpre' :: Context a b -> [(Node,b)] -- lpre' (p,_,_,_) = map flip2 p--- +-- -- lsuc' :: Context a b -> [(Node,b)] -- lsuc' (_,_,_,s) = map flip2 s--- --- out' :: Context a b -> [LEdge b] +--+-- out' :: Context a b -> [LEdge b] -- out' (_,v,_,s) = map (\(l,w)->(v,w,l)) s--- --- inn' :: Context a b -> [LEdge b] +--+-- inn' :: Context a b -> [LEdge b] -- inn' (p,v,_,_) = map (\(l,w)->(w,v,l)) p--- +-- -- outdeg' :: Context a b -> Int -- outdeg' (_,_,_,s) = length s--- +-- -- indeg' :: Context a b -> Int -- indeg' (p,_,_,_) = length p--- +-- -- deg' :: Context a b -> Int -- deg' (p,_,_,s) = length p+length s   -- 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@@ -212,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
Data/Graph/Inductive/Monad/IOArray.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+ -- (c) 2002 by Martin Erwig [see file COPYRIGHT]--- | Static IOArray-based Graphs  +-- | Static IOArray-based Graphs module Data.Graph.Inductive.Monad.IOArray(     -- * Graph Representation     SGr(..), GraphRep, Context', USGr,@@ -15,14 +17,14 @@ import Data.Array import Data.Array.IO import System.IO.Unsafe-import Data.Maybe  + ---------------------------------------------------------------------- -- GRAPH REPRESENTATION ---------------------------------------------------------------------- -data SGr a b = SGr (GraphRep a b)+newtype SGr a b = SGr (GraphRep a b)  type GraphRep a b = (Int,Array Node (Context' a b),IOArray Node Bool) type Context' a b = Maybe (Adj b,a,Adj b)@@ -43,10 +45,12 @@                         Nothing      -> ""                         Just (_,l,s) -> '\n':show v++":"++show l++"->"++show s'                           where s' = unsafePerformIO (removeDel m s)-               ++-- | Please note that this instance is unsafe. instance (Show a,Show b) => Show (SGr a b) where   show (SGr g) = showGraph g +-- | Please note that this instance is unsafe. instance (Show a,Show b) => Show (IO (SGr a b)) where   show g = unsafePerformIO (do {(SGr g') <- g; return (showGraph g')}) @@ -56,14 +60,14 @@ -}  -- GraphM--- +-- instance GraphM IO SGr where   emptyM = emptyN defaultGraphSize   isEmptyM g = do {SGr (n,_,_) <- g; return (n==0)}   matchM v g = do g'@(SGr (n,a,m)) <- g-                  case a!v of +                  case a!v of                     Nothing -> return (Nothing,g')-                    Just (pr,l,su) -> +                    Just (pr,l,su) ->                        do b <- readArray m v                           if b then return (Nothing,g') else                              do s  <- removeDel m su@@ -80,20 +84,20 @@                 vs'  = map fst vs                 n    = length vs                 addSuc (Just (p,l',s)) (l,w) = Just (p,l',(l,w):s)-		addSuc Nothing _ = error "mkGraphM (SGr): addSuc Nothing"+                addSuc Nothing _ = error "mkGraphM (SGr): addSuc Nothing"                 addPre (Just (p,l',s)) (l,w) = Just ((l,w):p,l',s)-		addPre Nothing _ = error "mkGraphM (SGr): addPre Nothing"+                addPre Nothing _ = error "mkGraphM (SGr): addPre Nothing"   labNodesM g = do (SGr (_,a,m)) <- g                    let getLNode vs (_,Nothing)      = return vs-                       getLNode vs (v,Just (_,l,_)) = -                           do b <- readArray m v +                       getLNode vs (v,Just (_,l,_)) =+                           do b <- readArray m v                               return (if b then vs else (v,l):vs)                    foldM getLNode [] (assocs a)-  + defaultGraphSize :: Int defaultGraphSize = 100 -emptyN :: Int -> IO (SGr a b) +emptyN :: Int -> IO (SGr a b) emptyN n = do m <- newArray (1,n) False               return (SGr (0,array (1,n) [(i,Nothing) | i <- [1..n]],m)) @@ -107,6 +111,3 @@ -- representing deleted marks removeDel :: IOArray Node Bool -> Adj b -> IO (Adj b) removeDel m = filterM (\(_,v)->do {b<-readArray m v;return (not b)})---
+ Data/Graph/Inductive/Monad/STArray.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}++-- (c) 2002 by Martin Erwig [see file COPYRIGHT]+-- | Static IOArray-based Graphs+module Data.Graph.Inductive.Monad.STArray(+    -- * Graph Representation+    SGr(..), GraphRep, Context', USGr,+    defaultGraphSize, emptyN,+    -- * Utilities+    removeDel,+) where++import Data.Graph.Inductive.Graph+import Data.Graph.Inductive.Monad++import Control.Monad+import Control.Monad.ST+import Data.Array+import Data.Array.ST+import System.IO.Unsafe++++----------------------------------------------------------------------+-- GRAPH REPRESENTATION+----------------------------------------------------------------------++newtype SGr s a b = SGr (GraphRep s a b)++type GraphRep s a b = (Int,Array Node (Context' a b),STArray s Node Bool)+type Context'   a b = Maybe (Adj b,a,Adj b)++type USGr s = SGr s () ()+++----------------------------------------------------------------------+-- CLASS INSTANCES+----------------------------------------------------------------------++-- Show+--+showGraph :: (Show a,Show b) => GraphRep RealWorld a b -> String+showGraph (_,a,m) = concatMap showAdj (indices a)+    where showAdj v | unsafeST (readArray m v) = ""+                    | otherwise = case a!v of+                        Nothing      -> ""+                        Just (_,l,s) -> '\n':show v++":"++show l++"->"++show s'+                          where s' = unsafeST (removeDel m s)++unsafeST :: ST RealWorld a -> a+unsafeST = unsafePerformIO . stToIO++-- | Please not that this instance is unsafe.+instance (Show a,Show b) => Show (SGr RealWorld a b) where+  show (SGr g) = showGraph g++{-+run :: Show (IO a) => IO a -> IO ()+run x = seq x (print x)+-}++-- GraphM+--+instance GraphM (ST s) (SGr s) where+  emptyM = emptyN defaultGraphSize+  isEmptyM g = do {SGr (n,_,_) <- g; return (n==0)}+  matchM v g = do g'@(SGr (n,a,m)) <- g+                  case a!v of+                    Nothing -> return (Nothing,g')+                    Just (pr,l,su) ->+                       do b <- readArray m v+                          if b then return (Nothing,g') else+                             do s  <- removeDel m su+                                p' <- removeDel m pr+                                let p = filter ((/=v).snd) p'+                                writeArray m v True+                                return (Just (p,v,l,s),SGr (n-1,a,m))+  mkGraphM vs es = do m <- newArray (1,n) False+                      return (SGr (n,pr,m))+          where nod  = array bnds (map (\(v,l)->(v,Just ([],l,[]))) vs)+                su   = accum addSuc nod (map (\(v,w,l)->(v,(l,w))) es)+                pr   = accum addPre su (map (\(v,w,l)->(w,(l,v))) es)+                bnds = (minimum vs',maximum vs')+                vs'  = map fst vs+                n    = length vs+                addSuc (Just (p,l',s)) (l,w) = Just (p,l',(l,w):s)+                addSuc Nothing _ = error "mkGraphM (SGr): addSuc Nothing"+                addPre (Just (p,l',s)) (l,w) = Just ((l,w):p,l',s)+                addPre Nothing _ = error "mkGraphM (SGr): addPre Nothing"+  labNodesM g = do (SGr (_,a,m)) <- g+                   let getLNode vs (_,Nothing)      = return vs+                       getLNode vs (v,Just (_,l,_)) =+                           do b <- readArray m v+                              return (if b then vs else (v,l):vs)+                   foldM getLNode [] (assocs a)++defaultGraphSize :: Int+defaultGraphSize = 100++emptyN :: Int -> ST s (SGr s a b)+emptyN n = do m <- newArray (1,n) False+              return (SGr (0,array (1,n) [(i,Nothing) | i <- [1..n]],m))++----------------------------------------------------------------------+-- UTILITIES+----------------------------------------------------------------------++++-- | filter list (of successors\/predecessors) through a boolean ST array+-- representing deleted marks+removeDel :: STArray s Node Bool -> Adj b -> ST s (Adj b)+removeDel m = filterM (\(_,v)->do {b<-readArray m v;return (not b)})
Data/Graph/Inductive/NodeMap.hs view
@@ -1,16 +1,18 @@+{-# LANGUAGE CPP #-}+ -- | Utility methods to automatically generate and keep track of a mapping -- between node labels and 'Node's. module Data.Graph.Inductive.NodeMap(     -- * Functional Construction     NodeMap,     -- ** Map Construction-    new, fromGraph, mkNode, mkNode_, mkNodes, mkNodes_, mkEdge, mkEdges,+    new, fromGraph, mkNode, mkNode_, mkNodes, mkLookupNode, mkNodes_, mkEdge, mkEdges,     -- ** Graph Construction     -- | These functions mirror the construction and destruction functions in     -- 'Data.Graph.Inductive.Graph', but use the given 'NodeMap' to look up     -- the appropriate 'Node's.  Note that the 'insMapNode' family of functions     -- will create new nodes as needed, but the other functions will not.-    insMapNode, insMapNode_, insMapEdge, delMapNode, delMapEdge, insMapNodes,+    insMapNode, insMapLookupNode, insMapNode_, insMapEdge, delMapNode, delMapEdge, insMapNodes,     insMapNodes_, insMapEdges, delMapNodes, delMapEdges, mkMapGraph,     -- * Monadic Construction     NodeMapM,@@ -21,24 +23,37 @@     run, run_, mkNodeM, mkNodesM, mkEdgeM, mkEdgesM,     -- ** Graph Construction     insMapNodeM, insMapEdgeM, delMapNodeM, delMapEdgeM, insMapNodesM,-    insMapEdgesM, delMapNodesM, delMapEdgesM+    insMapEdgesM, delMapNodesM, delMapEdgesM,++    -- ** Map inspection+    memberNode, lookupNode ) where -import Prelude hiding (map)-import qualified Prelude as P (map)-import Control.Monad.State-import Data.Graph.Inductive.Graph---import Data.Graph.Inductive.Tree-import Data.Graph.Inductive.Internal.FiniteMap+import           Control.Monad.Trans.State+import           Data.Graph.Inductive.Graph+import           Prelude                    hiding (map)+import qualified Prelude                    as P (map) -data (Ord a) => NodeMap a =-    NodeMap { map :: FiniteMap a Node,-	      key :: Int }-    deriving Show+import           Data.Map (Map)+import qualified Data.Map as M +#if MIN_VERSION_containers (0,4,2)+import Control.DeepSeq (NFData (..))+#endif++data NodeMap a =+    NodeMap { map :: Map a Node,+              key :: Int }+    deriving (Eq, Show, Read)++#if MIN_VERSION_containers (0,4,2)+instance (NFData a) => NFData (NodeMap a) where+  rnf (NodeMap mp k) = rnf mp `seq` rnf k+#endif+ -- | Create a new, empty mapping.-new :: (Ord a) => NodeMap a-new = NodeMap { map = emptyFM, key = 0 }+new :: NodeMap a+new = NodeMap { map = M.empty, key = 0 }  -- LNode = (Node, a) @@ -46,20 +61,35 @@ fromGraph :: (Ord a, Graph g) => g a b -> NodeMap a fromGraph g =     let ns = labNodes g-	aux (n, a) (m', k') = (addToFM m' a n, max n k')-	(m, k) = foldr aux (emptyFM, 0) ns+        aux (n, a) (m', k') = (M.insert a n m', max n k')+        (m, k) = foldr aux (M.empty, 0) ns     in NodeMap { map = m, key = k+1 } +-- | Is the node in the map ?+memberNode :: (Ord a) => a -> NodeMap a -> Bool+memberNode a = M.member a . map++-- | Lookup for the node in the map.+lookupNode :: (Ord a) => a -> NodeMap a -> Maybe Node+lookupNode a = M.lookup a . map+ -- | Generate a labelled node from the given label.  Will return the same node -- for the same label. mkNode :: (Ord a) => NodeMap a -> a -> (LNode a, NodeMap a)-mkNode m@(NodeMap mp k) a =-    case lookupFM mp a of-	Just i	-> ((i, a), m)-	Nothing	->-	    let m' = NodeMap { map = addToFM mp a k, key = k+1 }-	    in ((k, a), m')+mkNode m = forgetFst . mkLookupNode m+  where+    forgetFst (_,x,y)=(x,y) +-- | Act as 'mkNode', but return also a boolean set as @True@ if the node was+-- already in the map.+mkLookupNode :: (Ord a) => NodeMap a -> a -> (Bool, LNode a, NodeMap a)+mkLookupNode m@(NodeMap mp k) a =+    case M.lookup a mp of+        Just i        -> (True,(i, a), m)+        Nothing       ->+            let m' = NodeMap { map = M.insert a k mp, key = k+1 }+            in (False,(k, a), m')+ -- | Generate a labelled node and throw away the modified 'NodeMap'. mkNode_ :: (Ord a) => NodeMap a -> a -> LNode a mkNode_ m a = fst $ mkNode m a@@ -67,13 +97,13 @@ -- | Generate a 'LEdge' from the node labels. mkEdge :: (Ord a) => NodeMap a -> (a, a, b) -> Maybe (LEdge b) mkEdge (NodeMap m _) (a1, a2, b) =-    do n1 <- lookupFM m a1-       n2 <- lookupFM m a2+    do n1 <- M.lookup a1 m+       n2 <- M.lookup a2 m        return (n1, n2, b)  -- | 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)@@ -83,7 +113,7 @@ map' _ a [] = ([], a) map' f a (b:bs) =     let (c, a') = f a b-	(cs, a'') = map' f a' bs+        (cs, a'') = map' f a' bs     in (c:cs, a'')  -- | Construct a list of nodes and throw away the modified 'NodeMap'.@@ -95,25 +125,34 @@     let (n, m') = mkNode m a     in (insNode n g, m', n) +-- | Act as 'insMapNode', but return also a boolean set as @True@ if the node was+-- already in the map.+insMapLookupNode :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> (Bool, g a b, NodeMap a, LNode a)+insMapLookupNode m a g =+    let (b, n, m') = mkLookupNode m a+    in (b, insNode n g, m', n)+ insMapNode_ :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> g a b insMapNode_ m a g =     let (g', _, _) = insMapNode m a g     in g' +-- | Partial function: raises exception if passed nodes that are not in the graph. insMapEdge :: (Ord a, DynGraph g) => NodeMap a -> (a, a, b) -> g a b -> g a b insMapEdge m e g =-    let (Just e') = mkEdge m e-    in insEdge e' g+  case mkEdge m e of Just e' -> insEdge e' g+                     Nothing -> error "insMapEdge: invalid edge"  delMapNode :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> g a b delMapNode m a g =     let (n, _) = mkNode_ m a     in delNode n g +-- | Partial function: raises exception if passed nodes that are not in the graph. delMapEdge :: (Ord a, DynGraph g) => NodeMap a -> (a, a) -> g a b -> g a b delMapEdge m (n1, n2) g =-    let Just (n1', n2', _) = mkEdge m (n1, n2, ())-    in delEdge (n1', n2') g+    case mkEdge m (n1, n2, ()) of Just (n1', n2', _) -> delEdge (n1', n2') g+                                  Nothing -> error "delMapEdge: invalid edge"  insMapNodes :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> (g a b, NodeMap a, [LNode a]) insMapNodes m as g =@@ -125,27 +164,33 @@     let (g', _, _) = insMapNodes m as g     in g' +-- | Partial function: raises exception if passed nodes that are not in the graph. insMapEdges :: (Ord a, DynGraph g) => NodeMap a -> [(a, a, b)] -> g a b -> g a b insMapEdges m es g =-    let Just es' = mkEdges m es-    in insEdges es' g+    case mkEdges m es of Just es' -> insEdges es' g+                         Nothing -> error "insMapEdges: invalid edge"  delMapNodes :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> g a b delMapNodes m as g =     let ns = P.map fst $ mkNodes_ m as     in delNodes ns g +-- | Partial function: raises exception if passed nodes that are not in the graph. delMapEdges :: (Ord a, DynGraph g) => NodeMap a -> [(a, a)] -> g a b -> g a b delMapEdges m ns g =-    let Just ns' =  mkEdges m $ P.map (\(a, b) -> (a, b, ())) ns-	ns'' = P.map (\(a, b, _) -> (a, b)) ns'-    in delEdges ns'' g+    case mkEdges m $ P.map (\(a, b) -> (a, b, ())) ns of+      Nothing -> error "delMapEdges: invalid edges"+      Just ns' ->+        let ns'' = P.map (\(a, b, _) -> (a, b)) ns'+        in delEdges ns'' g +-- | Partial function: raises exception if passed a node that is not in the graph. mkMapGraph :: (Ord a, DynGraph g) => [a] -> [(a, a, b)] -> (g a b, NodeMap a) mkMapGraph ns es =     let (ns', m') = mkNodes new ns-	Just es' = mkEdges m' es-    in (mkGraph ns' es', m')+    in case mkEdges m' es of+         Just es' -> (mkGraph ns' es', m')+         Nothing -> error "mkMapGraph: invalid edges"  -- | Graph construction monad; handles passing both the 'NodeMap' and the -- 'Graph'.@@ -173,14 +218,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@@ -197,13 +242,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@@ -211,16 +256,16 @@        return r  -- | Monadic node construction.-mkNodeM :: (Ord a, DynGraph g) => a -> NodeMapM a b g (LNode a)+mkNodeM :: (Ord a) => a -> NodeMapM a b g (LNode a) mkNodeM = liftN2 mkNode -mkNodesM :: (Ord a, DynGraph g) => [a] -> NodeMapM a b g [LNode a]+mkNodesM :: (Ord a) => [a] -> NodeMapM a b g [LNode a] mkNodesM = liftN2 mkNodes -mkEdgeM :: (Ord a, DynGraph g) => (a, a, b) -> NodeMapM a b g (Maybe (LEdge b))+mkEdgeM :: (Ord a) => (a, a, b) -> NodeMapM a b g (Maybe (LEdge b)) mkEdgeM = liftN2' mkEdge -mkEdgesM :: (Ord a, DynGraph g) => [(a, a, b)] -> NodeMapM a b g (Maybe [LEdge b])+mkEdgesM :: (Ord a) => [(a, a, b)] -> NodeMapM a b g (Maybe [LEdge b]) mkEdgesM = liftN2' mkEdges  insMapNodeM :: (Ord a, DynGraph g) => a -> NodeMapM a b g (LNode a)
Data/Graph/Inductive/PatriciaTree.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE 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,57 +25,127 @@     )     where -import           Data.Graph.Inductive.Graph-import           Data.IntMap (IntMap)-import qualified Data.IntMap as IM-import           Data.List-import           Data.Maybe-import           Control.Arrow(second)+import Data.Graph.Inductive.Graph +import           Control.Applicative (liftA2)+import           Data.IntMap         (IntMap)+import qualified Data.IntMap         as IM+import           Data.List           (foldl', sort)+import           Data.Maybe          (fromMaybe)+import           Data.Tuple          (swap) +#if MIN_VERSION_containers (0,4,2)+import Control.DeepSeq (NFData(..))+#endif++#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as IMS+#else+import qualified Data.IntMap as IMS+#endif++#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics (Generic)+#endif++#if MIN_VERSION_base (4,8,0)+import Data.Bifunctor+#else+import Control.Arrow (second)+#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 (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) $+                    showString "mkGraph "+                    . shows (labNodes g)+                    . showString " "+                    . shows (labEdges g)++instance (Read a, Read b) => Read (Gr a b) where+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("mkGraph", s) <- lex r+    (ns,t) <- reads s+    (es,u) <- reads t+    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+        = let !g1 = IM.insert v (preds, l, succs) g+              !(np, preds) = fromAdjCounting p+              !(ns, succs) = fromAdjCounting s+              !g2 = addSucc g1 v np preds+              !g3 = addPred g2 v ns succs+          in Gr g3 +#if MIN_VERSION_containers (0,4,2)+instance (NFData a, NFData b) => NFData (Gr a b) where+  rnf (Gr g) = rnf g+#endif +instance Functor (Gr a) where+  fmap = fastEMap++#if MIN_VERSION_base (4,8,0)+instance Bifunctor Gr where+  bimap = fastNEMap++  first = fastNMap++  second = fastEMap+#endif+ matchGr :: Node -> Gr a b -> Decomp Gr a b matchGr node (Gr g)     = case IM.lookup node g of@@ -83,88 +156,113 @@             -> let !g1 = IM.delete node g                    !p' = IM.delete node p                    !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)+                   !g2 = clearPred g1 node s'+                   !g3 = clearSucc g2 node p'+               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 addS' v g+    g2 = IM.adjust addP' w g1 +    addS' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss)+    addP' (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) +{-# RULES+      "nemap/Data.Graph.Inductive.PatriciaTree"  nemap = fastNEMap+  #-}+fastNEMap :: forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d+fastNEMap fn fe (Gr g) = Gr (IM.map f g)+  where+    f :: Context' a b -> Context' c d+    f (ps, a, ss) = (IM.map (map fe) ps, fn a, IM.map (map fe) 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) +data FromListCounting a = FromListCounting !Int !(IntMap a)+  deriving (Eq, Show, Read) -toContext :: Node -> Context' a b -> Context a b-toContext v (ps, a, ss)-    = (toAdj ps, v, a, toAdj ss)+getFromListCounting :: FromListCounting a -> (Int, IntMap a)+getFromListCounting (FromListCounting i m) = (i, m)+{-# INLINE getFromListCounting #-} +fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)+fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty)+  where+    ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t)+{-# INLINE fromListWithKeyCounting #-} -fromContext :: Context a b -> Context' a b-fromContext (ps, _, a, ss)-    = (fromAdj ps, a, fromAdj ss)+fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)+fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y)+{-# INLINE fromListWithCounting #-} +fromAdjCounting :: Adj b -> (Int, IntMap [b])+fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap) -swap :: (a, b) -> (b, a)-swap (a, b) = (b, a)+-- We use differenceWith to modify a graph more than bulkThreshold times,+-- and repeated insertWith otherwise.+bulkThreshold :: Int+bulkThreshold = 5 +toContext :: Node -> Context' a b -> Context a b+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)+ -- 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@@ -174,33 +272,54 @@ addLists as  [a] = a : as addLists xs  ys  = xs ++ ys -addSucc :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b-addSucc g _ []              = g-addSucc g v ((l, p) : rest) = addSucc g' v rest-    where-      g' = IM.adjust f p g-      f (ps, l', ss) = (ps, l', IM.insertWith addLists v [l] ss)---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)+addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b+addSucc g0 v numAdd xs+  | numAdd < bulkThreshold = foldlWithKey' go g0 xs+  where+    go :: GraphRep a b -> Node -> [b] -> GraphRep a b+    go g p l = IMS.adjust f p g+      where f (ps, l', ss) = let !ss' = IM.insertWith addLists v l ss+                             in (ps, l', ss')+addSucc g v _ xs = IMS.differenceWith go g xs+  where+    go :: Context' a b -> [b] -> Maybe (Context' a b)+    go (ps, l', ss) l = let !ss' = IM.insertWith addLists v l ss+                        in Just (ps, l', ss') +foldlWithKey' :: (a -> IM.Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey' =+#if MIN_VERSION_containers (0,4,2)+  IM.foldlWithKey'+#else+  IM.foldWithKey . adjustFunc+  where+    adjustFunc f k b a = f a k b+#endif -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)+addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b+addPred g0 v numAdd xs+  | numAdd < bulkThreshold = foldlWithKey' go g0 xs+  where+    go :: GraphRep a b -> Node -> [b] -> GraphRep a b+    go g p l = IMS.adjust f p g+      where f (ps, l', ss) = let !ps' = IM.insertWith addLists v l ps+                             in (ps', l', ss)+addPred g v _ xs = IMS.differenceWith go g xs+  where+    go :: Context' a b -> [b] -> Maybe (Context' a b)+    go (ps, l', ss) l = let !ps' = IM.insertWith addLists v l ps+                        in Just (ps', l', ss) +clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b+clearSucc g v = IMS.differenceWith go g+  where+    go :: Context' a b -> x -> Maybe (Context' a b)+    go (ps, l, ss) _ = let !ss' = IM.delete v ss+                       in Just (ps, l, 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)+clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b+clearPred g v = IMS.differenceWith go g+  where+    go :: Context' a b -> x -> Maybe (Context' a b)+    go (ps, l, ss) _ = let !ps' = IM.delete v ps+                       in Just (ps', l, ss)
Data/Graph/Inductive/Query.hs view
@@ -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.DFS-import Data.Graph.Inductive.Query.BFS-import Data.Graph.Inductive.Query.SP-import Data.Graph.Inductive.Query.GVD-import Data.Graph.Inductive.Query.MST-import Data.Graph.Inductive.Query.Indep-import Data.Graph.Inductive.Query.MaxFlow-import Data.Graph.Inductive.Query.MaxFlow2-import Data.Graph.Inductive.Query.ArtPoint-import Data.Graph.Inductive.Query.BCC-import Data.Graph.Inductive.Query.Dominators-import Data.Graph.Inductive.Query.TransClos-import Data.Graph.Inductive.Query.Monad+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
Data/Graph/Inductive/Query/ArtPoint.hs view
@@ -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)@@ -66,8 +66,8 @@ -- contains: the node number v, the DFS number n, and the low number low. ------------------------------------------------------------------------------ lowTree :: DFSTree Int -> LOWTree Int-lowTree (B (v,n,[]  ) [] ) = Brc (v,n,n) [] -lowTree (B (v,n,bcks) [] ) = Brc (v,n,minbckEdge n bcks) [] +lowTree (B (v,n,[]  ) [] ) = Brc (v,n,n) []+lowTree (B (v,n,bcks) [] ) = Brc (v,n,minbckEdge n bcks) [] lowTree (B (v,n,bcks) trs) = Brc (v,n,lowv) ts                              where lowv     = min (minbckEdge n bcks) lowChild                                    lowChild = minimum (map getLow ts)@@ -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,6 +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-
Data/Graph/Inductive/Query/BCC.hs view
@@ -4,23 +4,23 @@   import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Query.DFS import Data.Graph.Inductive.Query.ArtPoint+import Data.Graph.Inductive.Query.DFS   ------------------------------------------------------------------------------ -- 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,37 +40,19 @@ -- 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 -                        where gs'' = embedContexts c gs'-                              gs' = gComponents g'-                              ((Just c,g'), gs''') = findGraph v gs+splitGraphs gs (v:vs) = case findGraph v gs of+                          ((Nothing, _), _) -> error "splitGraphs: invalid node"+                          ((Just c,g'), gs''') -> splitGraphs (gs''++gs''') vs+                            where gs'' = embedContexts c gs'+                                  gs' = gComponents g'  {-| Finds the bi-connected components of an undirected connected graph. 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)---------                                                ----------
Data/Graph/Inductive/Query/BFS.hs view
@@ -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,52 +35,54 @@         (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                         (Just c,g')  -> (v,j):leveln (vs++suci c (j+1)) g'-                        (Nothing,g') -> leveln vs g'  +                        (Nothing,g') -> leveln vs g'   -- 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                 = +                 | otherwise                 =       case match v g of         (Just c, g')  -> (u,v):bfenInternal (queuePutList (outU c) q') g'         (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)@@ -83,49 +91,52 @@ -- bft :: Node -> gr a b -> IT.InTree Node -- bft v g = IT.build $ map swap $ bfe v g --           where swap (x,y) = (y,x)--- +-- -- sp (shortest path wrt to number of edges) -- -- sp :: Node -> Node -> gr a b -> [Node] -- sp s t g = reverse $ IT.rootPath (bft s g) t  --- faster shortest paths +-- 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-         (Just c, g')  -> p:bf (queuePutList (map (:p) (suc' c)) q') g'-         (Nothing, g') -> bf q' g'-         where (p@(v:_),q') = queueGet q+       case queueGet q of+         ([], _) -> []+         (p@(v:_),q') ->+           case match v g of+             (Just c, g')  -> p:bf (queuePutList (map (:p) (suc' c)) q') g'+             (Nothing, g') -> bf q' g' -esp :: Graph gr => Node -> Node -> gr a b -> Path+esp :: (Graph gr) => Node -> Node -> gr a b -> Path esp s t = getPath t . bft s   -- lesp is a version of esp that returns labeled paths -- 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. +-- 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+       case queueGet q of+         (LP [], _) -> []+         (LP (p@((v,_):_)),q') ->+           case match v g of+             (Just c, g') ->+                 LP p:lbf (queuePutList (map (\v' -> LP (v':p)) (lsuc' c)) q') g'+             (Nothing, g') -> lbf q' g' -lesp :: Graph gr => Node -> Node -> gr a b -> LPath b+lesp :: (Graph gr) => Node -> Node -> gr a b -> LPath b lesp s t = getLPath t . lbft s-
Data/Graph/Inductive/Query/DFS.hs view
@@ -1,223 +1,249 @@ -- (c) 2000 - 2005 by Martin Erwig [see file COPYRIGHT]--- | Depth-First Search   -module Data.Graph.Inductive.Query.DFS(-    CFun,-    dfs,dfs',dff,dff',-    dfsWith, dfsWith',dffWith,dffWith',-    xdfsWith,xdfWith,xdffWith,-    -- * Undirected DFS-    udfs,udfs',udff,udff',-    -- * Reverse DFS-    rdff,rdff',rdfs,rdfs',-    -- * Applications of DFS\/DFF-    topsort,topsort',scc,reachable,-    -- * Applications of UDFS\/UDFF-    components,noComponents,isConnected-) where--import Data.Tree-import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Basic--------------------------------------------------------------------------- DFS AND FRIENDS-------------------------------------------------------------------------{---  Classification of all 32 dfs functions:--    dfs-function ::= [direction]"df"structure["With"]["'"]-    direction  -->  "x" | "u" | "r"-    structure  -->  "s" | "f"+-- | Depth-first search algorithms.+--+-- Names consist of:+--+--   1. An optional direction parameter, specifying which nodes to visit next.+--+--      [@u@] 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 ( -              |   structure-   direction  |   "s"   "f"-   ------------------------   + optional With + optional '-      "x"     | xdfs  xdff   -      " "     |  dfs   dff-      "u"     | udfs  udff-      "r"     | rdfs  rdff-   ------------------------+    CFun, -  Direction Parameter-  --------------------   x : parameterized by a function that specifies which nodes -       to be visited next+    -- * Standard+    dfs, dfs', dff, dff',+    dfsWith,  dfsWith', dffWith, dffWith',+    xdfsWith, xdfWith, xdffWith, -  " ": the "normal case: just follow successors- -   u : undirected, ie, follow predecesors and successors-   -   r : reverse, ie, follow predecesors+    -- * Undirected+    udfs, udfs', udff, udff',+    udffWith, udffWith', +    -- * Reversed+    rdff, rdff', rdfs, rdfs',+    rdffWith, rdffWith', -  Structure Parameter-  --------------------   s : result is a list of -        (a) objects computed from visited contexts  ("With"-version)-        (b) nodes                                   (normal version)+    -- * Applications of depth first search/forest+    topsort, topsort', scc, reachable, -   f : result is a tree/forest of -        (a) objects computed from visited contexts  ("With"-version)-        (b) nodes                                   (normal version)+    -- * Applications of undirected depth first search/forest+    components, noComponents, isConnected, condensation -  Optional Suffixes-  ------------------   With : objects to be put into list/tree are given by a function-          on contexts, default for non-"With" versions: nodes+) where -   '    : parameter node list is given implicitly by the nodes of the -          graph to be traversed, default for non-"'" versions: nodes-          must be provided explicitly+import Data.Graph.Inductive.Basic+import Data.Graph.Inductive.Graph+import Data.Tree+import qualified Data.Map as Map+import Control.Monad (liftM2)+import Data.Tuple (swap)  -  Defined are only the following 18 most important function versions:--    xdfsWith-     dfsWith,dfsWith',dfs,dfs'-     udfs,udfs'-     rdfs,rdfs'-    xdffWith-     dffWith,dffWith',dff,dff'-     udff,udff'-     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                          (Just c,g')  -> f c:xdfsWith d f (d c++vs) g'-                         (Nothing,g') -> xdfsWith d f vs g'  +                         (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]-udfs = xdfsWith neighbors' 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]-rdfs = xdfsWith pre' 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-                        (Nothing,g1) -> xdfWith d f vs g1 -                        (Just c,g1)  -> (Node (f c) ts:ts',g3) +                        (Nothing,g1) -> xdfWith d f vs g1+                        (Just c,g1)  -> (Node (f c) ts:ts',g3)                                  where (ts,g2)  = xdfWith d f (d c) g1-                                       (ts',g3) = xdfWith d f vs g2 +                                       (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----udff :: Graph gr => [Node] -> gr a b -> [Tree Node]-udff = xdffWith neighbors' node' -udff' :: Graph gr => gr a b -> [Tree Node]-udff' = fixNodes udff+-- | 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' --- reverse dff, ie, following predecessors----rdff :: Graph gr => [Node] -> gr a b -> [Tree Node]-rdff = xdffWith pre' node'+udffWith' :: (Graph gr) => CFun a b c -> gr a b -> [Tree c]+udffWith' f = fixNodes (udffWith f) -rdff' :: Graph gr => gr a b -> [Tree Node]-rdff' = fixNodes rdff+udff' :: (Graph gr) => gr a b -> [Tree Node]+udff' = udffWith' node'  +-- | 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' f = fixNodes (rdffWith f)++rdff' :: (Graph gr) => gr a b -> [Tree Node]+rdff' = rdffWith' node'++ ---------------------------------------------------------------------- -- 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++    getN = (vMap Map.!)+    es = [ (getN c1, getN c2, ()) | c1 <- sccs, c2 <- sccs+                                  , (c1 /= c2) && any (hasEdge gr) (liftM2 (,) c1 c2) ]
Data/Graph/Inductive/Query/Dominators.hs view
@@ -12,24 +12,25 @@     iDom ) where -import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Query.DFS-import Data.Tree (Tree(..))-import qualified Data.Tree as T-import Data.Array-import Data.IntMap (IntMap)-import qualified Data.IntMap as I+import           Data.Array+import           Data.Graph.Inductive.Graph+import           Data.Graph.Inductive.Query.DFS+import           Data.IntMap                    (IntMap)+import qualified Data.IntMap                    as I+import           Data.Maybe (mapMaybe)+import           Data.Tree                      (Tree (..))+import qualified Data.Tree                      as T --- | return immediate dominators for each node of a graph, given a root-iDom :: Graph gr => gr a b -> Node -> [(Node,Node)]+-- | return immediate dominators for each reachable node of a graph, given a root+iDom :: (Graph gr) => gr a b -> Node -> [(Node,Node)] iDom g root = let (result, toNode, _) = idomWork g root               in  map (\(a, b) -> (toNode ! a, toNode ! b)) (assocs result) --- | return the set of dominators of the nodes of a graph, given a root-dom :: Graph gr => gr a b -> Node -> [(Node,[Node])]+-- | return the set of dominators of the reachable nodes of a graph, given a root+dom :: (Graph gr) => gr a b -> Node -> [(Node,[Node])] dom g root = let-    (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,44 +49,46 @@ type ToNode = Array Node' Node type FromNode = IntMap Node' -idomWork :: Graph gr => gr a b -> Node -> (IDom, ToNode, FromNode)-idomWork g root = let-    -- use depth first tree from root do build the first approximation-    trees@(~[tree]) = dff [root] g-    -- relabel the tree so that paths from the root have increasing nodes-    (s, ntree) = numberTree 0 tree-    -- the approximation iDom0 just maps each node to its parent-    iDom0 = array (1, s-1) (tail $ treeEdges (-1) ntree)-    -- fromNode translates graph nodes to relabeled (internal) nodes-    fromNode = I.unionWith const (I.fromList (zip (T.flatten tree) (T.flatten ntree))) (I.fromList (zip (nodes g) (repeat (-1))))-    -- toNode translates internal nodes to graph nodes-    toNode = array (0, s-1) (zip (T.flatten ntree) (T.flatten tree))-    preds = array (1, s-1) [(i, filter (/= -1) (map (fromNode I.!)-                            (pre g (toNode ! i)))) | i <- [1..s-1]]-    -- iteratively improve the approximation to find iDom.-    iDom = fixEq (refineIDom preds) iDom0-  in-    if null trees then error "Dominators.idomWork: root not in graph"-                  else (iDom, toNode, fromNode)+idomWork :: (Graph gr) => gr a b -> Node -> (IDom, ToNode, FromNode)+idomWork g root =+  case dff [root] g of+    [] -> error "Dominators.idomWork: root not in graph"+    tree : _ ->+      let+        nds = reachable root g+        -- use depth first tree from root do build the first approximation+        -- relabel the tree so that paths from the root have increasing nodes+        (s, ntree) = numberTree 0 tree+        -- the approximation iDom0 just maps each node to its parent+        iD0 = array (1, s-1) (tail $ treeEdges (-1) ntree)+        -- fromNode translates graph nodes to relabeled (internal) nodes+        fromNode = I.unionWith const (I.fromList (zip (T.flatten tree) (T.flatten ntree))) (I.fromList (zip nds (repeat (-1))))+        -- toNode translates internal nodes to graph nodes+        toNode = array (0, s-1) (zip (T.flatten ntree) (T.flatten tree))+        preds = array (1, s-1) [(i, filter (/= -1) (mapMaybe (`I.lookup` fromNode)+                                (pre g (toNode ! i)))) | i <- [1..s-1]]+        -- iteratively improve the approximation to find iDom.+        iD = fixEq (refineIDom preds) iD0+      in (iD, toNode, fromNode)  -- for each node in iDom, find the intersection of all its predecessor's -- dominating sets, and update iDom accordingly. 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 +109,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
Data/Graph/Inductive/Query/GVD.hs view
@@ -1,46 +1,67 @@ -- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT]--- | Graph Voronoi Diagram -+-- | 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, --    vdO,nnO,nsO ) where +import Data.List  (nub) import Data.Maybe (listToMaybe)-import Data.List (nub)  import qualified Data.Graph.Inductive.Internal.Heap as H +import Data.Graph.Inductive.Basic import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Query.SP (dijkstra) import Data.Graph.Inductive.Internal.RootPath-import Data.Graph.Inductive.Basic+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 :: 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
Data/Graph/Inductive/Query/Indep.hs view
@@ -1,24 +1,35 @@ -- (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)+  | otherwise =+      case match v g of+        (Nothing,_) -> error "indepSize: unexpected invalid node"+        (Just c,g') ->+          let il1@(_,l1)  = indepSize g'+              il2@(_,l2)  = ((v:) *** (+1)) $ indepSize (delNodes (neighbors' c) g')+          in if l1 > l2 then il1 else il2+  where+    vs          = nodes g+    v           = snd . maximumBy (compare `on` fst)+                  . map ((,) =<< deg g) $ vs
Data/Graph/Inductive/Query/MST.hs view
@@ -1,41 +1,44 @@ -- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT]--- | Minimum-Spanning-Tree Algorithms +-- | Minimum-Spanning-Tree Algorithms  module Data.Graph.Inductive.Query.MST (     msTreeAt,msTree,     -- * Path in MST-    msPath+    msPath,+    -- * Types used+    LRTree ) where -import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Internal.RootPath-import qualified Data.Graph.Inductive.Internal.Heap as H+import           Data.Graph.Inductive.Graph+import qualified Data.Graph.Inductive.Internal.Heap     as H+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 prim h g | H.isEmpty h || isEmpty g = [] prim h g =-    case match v g of-         (Just c,g')  -> p:prim (H.mergeAll (h':newEdges p c)) g'-         (Nothing,g') -> prim h' g'  -    where (_,p@(LP ((v,_):_)),h') = H.splitMin h+  case H.splitMin h of+    (_,p@(LP ((v,_):_)),h') ->+      case match v g of+           (Just c,g')  -> p:prim (H.mergeAll (h':newEdges p c)) g'+           (Nothing,g') -> prim h' g'+    _ -> []  msTreeAt :: (Graph gr,Real b) => Node -> gr a b -> LRTree b-msTreeAt v 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 :: Path -> Path -> Path+joinPaths p = joinAt (head p) p+ joinAt :: Node -> Path -> Path -> Path joinAt _ (v:vs) (w:ws) | v==w = joinAt v vs ws joinAt x p      q             = reverse p++(x:q)-
Data/Graph/Inductive/Query/MaxFlow.hs view
@@ -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)  -- | -- @@@ -51,77 +54,85 @@ --                            i         (i,0,i) -- label of every edge from a---->b to a------->b -- @--- +-- -- 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 --- | 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+-- | 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 =+  case break ((v==) . snd) s of+    (rs, ((x,y,z),w):rs') -> rs ++ ((x,y+cf',z-cf'),w) : rs'+    _ -> error "updAdjList: invalid node"+  where+    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 graph 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--- the maximum flow for s=1 and t=6 (23) coincides with the example but the --- flow itself is slightly different since the textbook does not compute the --- shortest augmenting path from s to t, but just any path. However remember +-- the maximum flow for s=1 and t=6 (23) coincides with the example but the+-- flow itself is slightly different since the textbook does not compute the+-- shortest augmenting path from s to t, but just any path. However remember -- that for a given flow graph the maximum flow is not unique. -- (gr595 is defined in GraphData.hs) --------------------------------------------------------------------------------
Data/Graph/Inductive/Query/MaxFlow2.hs view
@@ -6,15 +6,16 @@  --   ekSimple, ekFused, ekList) where -import Data.List+ import Data.Maybe  import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Tree-import Data.Graph.Inductive.Internal.FiniteMap import Data.Graph.Inductive.Internal.Queue-import Data.Graph.Inductive.Query.BFS (bft)+import Data.Graph.Inductive.PatriciaTree+import Data.Graph.Inductive.Query.BFS      (bft) +import           Data.Set (Set)+import qualified Data.Set as S  ------------------------------------------------------------------------------ -- Data types@@ -24,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)@@ -32,7 +33,8 @@ type DirPath=[(Node, Direction)] type DirRTree=[DirPath] -pathFromDirPath = map (\(n,_)->n)+pathFromDirPath :: DirPath -> [Node]+pathFromDirPath = map fst  ------------------------------------------------------------------------------ -- Example networks@@ -74,8 +76,8 @@ -- EXTRACT fglEdmondsFused.txt -- Compute an augmenting path augPathFused :: Network -> Node -> Node -> Maybe DirPath-augPathFused g s t = listToMaybe $ map reverse $ -    filter (\((u,_):_) -> u==t) tree+augPathFused g s t = listToMaybe $ map reverse $+    filter ((==t) . fst . head) tree     where tree = bftForEK s g  -- Breadth First Search wrapper function@@ -85,8 +87,12 @@ -- Breadth First Search, tailored for Edmonds & Karp bfForEK :: Queue DirPath -> Network -> DirRTree bfForEK q g-    | queueEmpty q || isEmpty g = []-    | otherwise                 = case match v g of+  | queueEmpty q || isEmpty g = []+  | otherwise                 =+     case queueGet q of+      ([], _) -> []+      (p@((v,_):_), q1) ->+       case match v g of         (Nothing, g')                     -> bfForEK q1 g'         (Just (preAdj, _, _, sucAdj), g') -> p:bfForEK q2 g'             where@@ -98,28 +104,31 @@                 -- Traverse edges forwards if flow less than capacity                 suc2 = [ (sucNode,Forward):p                     | ((c, f), sucNode) <- sucAdj, c>f]-    where (p@((v,_):_), q1)=queueGet q --- Extract augmenting path from network; return path as a sequence of --- edges with direction of traversal, and new network with augmenting +-- Extract augmenting path from network; return path as a sequence of+-- edges with direction of traversal, and new network with augmenting -- path removed.-extractPathFused :: Network -> DirPath +extractPathFused :: Network -> DirPath     -> ([DirEdge (Double,Double)], Network) extractPathFused g []  = ([], g) extractPathFused g [(_,_)] = ([], g) extractPathFused g ((u,_):rest@((v,Forward):_)) =-    ((u, v, l, Forward):tailedges, newerg)-        where (tailedges, newerg) = extractPathFused newg rest-              Just (l, newg)    = extractEdge g u v (\(c,f)->(c>f))+  case extractEdge g u v (uncurry (>)) of+    Just (l, newg) ->+      let (tailedges, newerg) = extractPathFused newg rest+      in ((u, v, l, Forward):tailedges, newerg)+    Nothing -> error "extractPathFused Forward: invalid edge" extractPathFused g ((u,_):rest@((v,Backward):_)) =-    ((v, u, l, Backward):tailedges, newerg)-        where (tailedges, newerg) = extractPathFused newg rest-              Just (l, newg)    = extractEdge g v u (\(_,f)->(f>0))+  case extractEdge g v u (\(_,f)->(f>0)) of+    Just (l, newg) ->+      let (tailedges, newerg) = extractPathFused newg rest+      in ((v, u, l, Backward):tailedges, newerg)+    Nothing -> error "extractPathFused Backward: invalid edge" --- ekFusedStep :: EKStepFunc+ekFusedStep :: EKStepFunc ekFusedStep g s t = case maybePath of-        Just _	  -> -            Just ((insEdges (integrateDelta es delta) newg), delta)+        Just _          ->+            Just (insEdges (integrateDelta es delta) newg, delta)         Nothing   -> Nothing     where maybePath     = augPathFused g s t           (es, newg) = extractPathFused g (fromJust maybePath)@@ -134,17 +143,17 @@  -- EXTRACT fglEdmondsSimple.txt residualGraph :: Network -> Gr () Double-residualGraph g = -    mkGraph (labNodes g) -        ([(u, v, c-f) | (u, v, (c,f)) <- labEdges g, c>f ] ++ +residualGraph g =+    mkGraph (labNodes g)+        ([(u, v, c-f) | (u, v, (c,f)) <- labEdges g, c>f ] ++          [(v, u, f) | (u,v,(_,f)) <- labEdges g, f>0])  augPath :: Network -> Node -> Node -> Maybe Path-augPath g s t = listToMaybe $ map reverse $ filter (\(u:_) -> u==t) tree+augPath g s t = listToMaybe $ map reverse $ filter ((==t) . head) tree     where tree = bft s (residualGraph g)  -- Extract augmenting path from network; return path as a sequence of--- edges with direction of traversal, and new network with augmenting +-- edges with direction of traversal, and new network with augmenting -- path removed. extractPath :: Network -> Path -> ([DirEdge (Double,Double)], Network) extractPath g []  = ([], g)@@ -155,54 +164,54 @@             where (tailedges, newerg) = extractPath newg (v:ws)         Nothing          ->             case revExtract of-                Just (l, newg) -> +                Just (l, newg) ->                     ((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))+                Nothing               -> error "extractPath: revExtract == Nothing"+    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 extractEdge :: Gr a b -> Node -> Node -> (b->Bool) -> Maybe (b, Gr a b) extractEdge g u v p =-    case adj of-        Just (el, _) -> Just (el, (p', node, l, rest) & newg)-        Nothing      -> Nothing-    where (Just (p', node, l, s), newg) = match u g-          (adj, rest)=extractAdj s -              (\(l', dest) -> (dest==v) && (p l'))+    case match u g of+      ((Just (p', node, l, s), newg)) ->+        let (adj, rest)=extractAdj s (\(l', dest) -> dest==v && p l')+        in do (el, _) <- adj+              Just (el, (p', node, l, rest) & newg)+      _ -> Nothing --- Extract an item from an adjacency list that satisfies a given +-- Extract an item from an adjacency list that satisfies a given -- predicate. Return the item and the rest of the adjacency list extractAdj :: Adj b -> ((b,Node)->Bool) -> (Maybe (b,Node), Adj b) extractAdj []         _ = (Nothing, []) extractAdj (adj:adjs) p     | p adj     = (Just adj, adjs)-    | otherwise = (theone, adj:rest) +    | otherwise = (theone, adj:rest)         where (theone, rest)=extractAdj adjs p  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 +integrateDelta :: [DirEdge (Double,Double)] -> Double     -> [LEdge (Double, Double)]-integrateDelta []	  _ = []+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), Backward) -> -        (u, v, (c, f-delta)) : (integrateDelta es delta)+    (u, v, (c, f), Forward) ->+        (u, v, (c, f+delta)) : integrateDelta es delta+    (u, v, (c, f), Backward) ->+        (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 _ ->+            Just (insEdges (integrateDelta es delta) newg, delta)         Nothing   -> Nothing     where maybePath  = augPath g s t           (es, newg) = extractPath g (fromJust maybePath)@@ -211,7 +220,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)@@ -222,25 +231,15 @@ -- Alternative implementation: Process list of edges to extract path instead -- of operating on graph structure --- EXTRACT fglEdmondsList.txt-setFromList :: Ord a => [a] -> FiniteMap a ()-setFromList [] = emptyFM-setFromList (x:xs) = addToFM (setFromList xs) x ()--setContains :: Ord a => FiniteMap a () -> a -> Bool-setContains m i = case (lookupFM m i) of-    Nothing -> False-    Just () -> True--extractPathList :: [LEdge (Double, Double)] -> FiniteMap (Node,Node) () +extractPathList :: [LEdge (Double, Double)] -> Set (Node,Node)     -> ([DirEdge (Double, Double)], [LEdge (Double, Double)]) extractPathList []                 _ = ([], []) extractPathList (edge@(u,v,l@(c,f)):es) set-    | (c>f) && (setContains set (u,v)) = -        let (pathrest, notrest)=extractPathList es (delFromFM set (u,v))+    | (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) && (setContains set (v,u)) =-        let (pathrest, notrest)=extractPathList es (delFromFM set (u,v))+    | (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                        =         let (pathrest, notrest)=extractPathList es set in@@ -250,14 +249,13 @@ 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) -              (setFromList (zip justPath (tail justPath)))+          (es, otheredges) = extractPathList (labEdges g)+              (S.fromList (zip justPath (tail justPath)))           delta         = minimum $ getPathDeltas es           justPath      = pathFromDirPath (fromJust maybePath)  ekList :: Network -> Node -> Node -> (Network, Double) ekList = ekWith ekStepList -- ENDEXTRACT-
Data/Graph/Inductive/Query/Monad.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP, MultiParamTypeClasses #-}+ -- (c) 2002 by Martin Erwig [see file COPYRIGHT] -- | Monadic Graph Algorithms @@ -22,13 +24,17 @@  -- Why all this? ----- graph monad ensures single-threaded access +-- graph monad ensures single-threaded access --  ==> we can safely use imperative updates in the graph implementation -- +import Control.Monad (ap, liftM, liftM2) import Data.Tree---import Control.Monad (liftM) +#if __GLASGOW_HASKELL__ < 710+import Control.Applicative (Applicative (..))+#endif+ import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Monad @@ -51,40 +57,46 @@ -- monadic graph transformer monad ---------------------------------------------------------------------- -data GT m g a = MGT (m g -> m (a,g))+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+    fmap  = liftM -instance Monad m => Monad (GT m g) where-  return x = MGT (\mg->do {g<-mg; return (x,g)})+instance (Monad m) => Applicative (GT m g) where+    pure x  = MGT (\mg->do {g<-mg; return (x,g)})+    (<*>) = ap++instance (Monad m) => Monad (GT m g) where+  return = pure   f >>= h  = MGT (\mg->do {(x,g)<-apply f mg; apply' (h x) g}) -condMGT' :: Monad m => (s -> Bool) -> GT m s a -> GT m s a -> GT m s a+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' p mg f u = condMGT' p (return u) ++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 p mg f u = condMGT p (return u) +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)})  @@ -94,36 +106,33 @@   -- 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)  @@ -132,23 +141,23 @@ -- some derived graph recursion operators ---------------------------------------------------------------------- --- +-- -- graphRec :: GraphMonad a b c -> (c -> d -> d) -> d -> GraphMonad a b d--- graphRec f g u = cond isEmpty (return u) +-- graphRec f g u = cond isEmpty (return u) --                               (do x <- f --                                   y <- graphRec f g u --                                   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 -graphRec' :: (Graph gr,GraphM m gr) => GT m (gr a b) c -> +graphRec' :: (Graph gr,GraphM m gr) => GT m (gr a b) c ->                            (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  @@ -158,21 +167,21 @@ ----------------------------------------------------------------------  -- 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)  @@ -188,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@@ -197,31 +206,31 @@                     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-             if b||null vs then return ([],g) else -                let (v:vs') = vs in-                do (mc,g1) <- matchM v mg+             case (b, vs) of+               (False, v:vs') -> do+                   (mc,g1) <- matchM v mg                    case mc of                      Nothing -> apply (dffM vs') (return g1)                      Just c  -> do (ts, g2) <- apply (dffM (suc' c)) (return g1)                                    (ts',g3) <- apply (dffM vs') (return g2)                                    return (Node (node' c) ts:ts',g3)+               _ -> return ([],g)           ) -graphDff :: GraphM m gr => [Node] -> m (gr a b) -> m [Tree Node]+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}-
Data/Graph/Inductive/Query/SP.hs view
@@ -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,23 +15,66 @@ 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.+--+--   The edge labels of type @b@ are the edge weights; negative edge+--   weights are not supported.+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-         (Just c,g')  -> p:dijkstra (H.mergeAll (h':expand d p c)) g'-         (Nothing,g') -> dijkstra h' g'  -    where (_,p@(LP ((v,d):_)),h') = H.splitMin h-        -spTree :: (Graph gr, Real b) => Node -> gr a b -> LRTree b+  case H.splitMin h of+    (_,p@(LP ((v,d):_)),h') ->+      case match v g of+           (Just c,g')  -> p:dijkstra (H.mergeAll (h':expand d p c)) g'+           (Nothing,g') -> dijkstra h' g'+    _ -> []++-- | Tree of shortest paths from a certain node to the rest of the+--   (reachable) nodes.+--+--   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.+--+--   The edge labels of type @b@ are the edge weights; negative edge+--   weights are not supported.+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, if any.+--+--   Returns 'Nothing' if there is no path, and @'Just' <path length>@+--   otherwise.+--+--   The edge labels of type @b@ are the edge weights; negative edge+--   weights are not supported.+spLength :: (Graph gr, Real b)+    => Node -- ^ Start+    -> Node -- ^ Destination+    -> gr a b+    -> Maybe b spLength s t = getDistance t . spTree s -sp :: (Graph gr, Real b) => Node -> Node -> gr a b -> Path-sp s t = getLPathNodes t . spTree s+-- | Shortest path between two nodes, if any.+--+--   Returns 'Nothing' if the destination is not reachable from the+--   start node, and @'Just' <path>@ otherwise.+--+--   The edge labels of type @b@ are the edge weights; negative edge+--   weights are not supported.+sp :: (Graph gr, Real b)+    => Node -- ^ Start+    -> Node -- ^ Destination+    -> gr a b+    -> Maybe Path+sp s t g = case getLPathNodes t (spTree s g) of+  [] -> Nothing+  p  -> Just p
Data/Graph/Inductive/Query/TransClos.hs view
@@ -1,21 +1,41 @@ module Data.Graph.Inductive.Query.TransClos(-    trc+    trc, rc, tc ) where  import Data.Graph.Inductive.Graph-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')+import Data.Graph.Inductive.Query.BFS (bfen)  {-| 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 g = insEdges (getNewEdges ln g) (insNodes ln empty)-        where ln = labNodes g-                    +tc :: (DynGraph gr) => gr a b -> gr a ()+tc g = newEdges `insEdges` insNodes ln empty+  where+    ln       = labNodes g+    newEdges = [ (u, v, ()) | (u, _) <- ln, (_, v) <- bfen (outU g u) g ]+    outU gr  = map toEdge . out gr++{-|+Finds the reflexive-transitive closure of a directed graph.+Given a graph G=(V,E), its reflexive-transitive closure is the graph:+G* = (V,E*) where E*={(i,j): i,j in V and either i = j or there is a path from i to j in G}+-}+trc :: (DynGraph gr) => gr a b -> gr a ()+trc g = newEdges `insEdges` insNodes ln empty+  where+    ln       = labNodes g+    newEdges = [ (u, v, ()) | (u, _) <- ln, (_, v) <- bfen [(u, u)] g ]++{-|+Finds the reflexive closure of a directed graph.+Given a graph G=(V,E), its reflexive closure is the graph:+G* = (V,Er union E) where Er = {(i,i): i in V}+-}+rc :: (DynGraph gr) => gr a b -> gr a ()+rc g = (newEdges ++ oldEdges) `insEdges` insNodes ln empty+  where+    ln       = labNodes g+    newEdges = [ (u, u, ()) | (u, _) <- ln ]+    oldEdges = [ (u, v, ()) | (u, v, _) <- labEdges g ]
Data/Graph/Inductive/Tree.hs view
@@ -1,99 +1,167 @@+{-# 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'+--+--   You will probably have better performance using the+--   "Data.Graph.Inductive.PatriciaTree" implementation instead.  module Data.Graph.Inductive.Tree (Gr,UGr) where -import Data.List        (foldl')- import Data.Graph.Inductive.Graph-import Data.Graph.Inductive.Internal.FiniteMap -import Data.Maybe (fromJust)+import           Control.Applicative (liftA2)+import           Data.List           (foldl', sort)+import           Data.Map            (Map)+import qualified Data.Map            as M+import           Data.Maybe          (fromMaybe) +#if MIN_VERSION_containers (0,4,2)+import Control.DeepSeq (NFData (..))+#endif +#if __GLASGOW_HASKELL__ >= 702+import GHC.Generics (Generic)+#endif++#if MIN_VERSION_base (4,8,0)+import Data.Bifunctor+#else+import Control.Arrow (first, second)+#endif+ ---------------------------------------------------------------------- -- GRAPH REPRESENTATION ---------------------------------------------------------------------- -data Gr a b = Gr (GraphRep a b)+newtype Gr a b = Gr (GraphRep a b)+#if __GLASGOW_HASKELL__ >= 702+  deriving (Generic)+#endif -type GraphRep a b = FiniteMap Node (Context' a b)+type GraphRep a b = Map Node (Context' a b) type Context' a b = (Adj b,a,Adj 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 (p,n,s) = (sort p,n,sort s) --- Show----showsGraph :: (Show a,Show b) => GraphRep a b -> ShowS-showsGraph Empty = id-showsGraph (Node _ l (v,(_,l',s)) r) = showsGraph l . ('\n':) . -     shows v . (':':) . shows l' . ("->"++) . shows s . showsGraph r-                -instance (Show a,Show b) => Show (Gr a b) where-  showsPrec _ (Gr g) = showsGraph g+instance (Show a, Show b) => Show (Gr a b) where+  showsPrec d g = showParen (d > 10) $+                    showString "mkGraph "+                    . shows (labNodes g)+                    . showString " "+                    . shows (labEdges g) +instance (Read a, Read b) => Read (Gr a b) where+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("mkGraph", s) <- lex r+    (ns,t) <- reads s+    (es,u) <- reads t+    return (mkGraph ns es, u)  -- Graph--- +-- instance Graph Gr where-  empty           = Gr emptyFM-  isEmpty (Gr g)  = case g of {Empty -> True; _ -> False}-  match           = matchGr-  mkGraph vs es   = (insEdges' . insNodes vs) empty-        where-          insEdges' g = foldl' (flip insEdge) g es+  empty             = Gr M.empty -  labNodes (Gr g) = map (\(v,(_,l,_))->(v,l)) (fmToList g)-  -- more efficient versions of derived class members-  ---  matchAny (Gr Empty)                = error "Match Exception, Empty Graph"-  matchAny g@(Gr (Node _ _ (v,_) _)) = (c,g') where (Just c,g') = matchGr v g-  noNodes   (Gr g) = sizeFM g-  nodeRange (Gr Empty) = (0,0)-  nodeRange (Gr g)     = (ix (minFM g),ix (maxFM g)) where ix = fst.fromJust-  labEdges  (Gr g) = concatMap (\(v,(_,_,s))->map (\(l,w)->(v,w,l)) s) (fmToList g)+  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 -matchGr v (Gr g) = -      case splitFM g v of -           Nothing -> (Nothing,Gr g)-           Just (g',(_,(p,l,s))) -> (Just (p',v,l,s),Gr g2)-                where s'   = filter ((/=v).snd) s-                      p'   = filter ((/=v).snd) p-                      g1   = updAdj g' s' (clearPred v)-                      g2   = updAdj g1 p' (clearSucc v)+  mkGraph vs es     = insEdges es+                      . Gr+                      . M.fromList+                      . map (second (\l -> ([],l,[])))+                      $ vs +  labNodes (Gr g)   = map (\(v,(_,l,_))->(v,l)) (M.toList g) +  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 (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+-- GraphRep, clean up the remainders.+cleanSplit :: Node -> Context' a b -> GraphRep a b+              -> (Context a b, Gr a b)+cleanSplit v (p,l,s) g = (c, Gr g')+  where+    -- Note: loops are kept only in successor list+    c = (p', v, l, s)+    p' = rmLoops p+    s' = rmLoops s+    rmLoops = filter ((/=v) . snd)++    g' = updAdj s' (clearPred v) . updAdj p' (clearSucc v) $ g+ -- DynGraph--- +-- instance DynGraph Gr where-  (p,v,l,s) & (Gr g) | elemFM g v = error ("Node Exception, Node: "++show v)-                     | otherwise  = Gr g3-      where g1 = addToFM g v (p,l,s)-            g2 = updAdj g1 p (addSucc v)-            g3 = updAdj g2 s (addPred v)+  (p,v,l,s) & (Gr g) = Gr+                       . updAdj p (addSucc v)+                       . updAdj s (addPred v)+                       $ M.alter addCntxt v g+    where+      addCntxt = maybe (Just cntxt')+                       (const (error ("Node Exception, Node: "++show v)))+      cntxt' = (p,l,s) +#if MIN_VERSION_containers (0,4,2)+instance (NFData a, NFData b) => NFData (Gr a b) where+  rnf (Gr g) = rnf g+#endif +instance Functor (Gr a) where+  fmap = emap++#if MIN_VERSION_base (4,8,0)+instance Bifunctor Gr where+  bimap = nemap++  first = nmap++  second = emap+#endif+ ---------------------------------------------------------------------- -- UTILITIES ---------------------------------------------------------------------- +addSucc :: Node -> b -> Context' a b -> Context' a b addSucc v l (p,l',s) = (p,l',(l,v):s)++addPred :: Node -> b -> Context' a b -> Context' a b addPred v l (p,l',s) = ((l,v):p,l',s) +clearSucc :: Node -> b -> Context' a b -> Context' a b clearSucc v _ (p,l,s) = (p,l,filter ((/=v).snd) s)-clearPred v _ (p,l,s) = (filter ((/=v).snd) p,l,s) -updAdj :: GraphRep a b -> Adj b -> (b -> Context' a b -> Context' a b) -> GraphRep a b-updAdj g []         _              = g-updAdj g ((l,v):vs) f | elemFM g v = updAdj (updFM g v (f l)) vs f-                      | otherwise  = error ("Edge Exception, Node: "++show v)--+clearPred :: Node -> b -> Context' a b -> Context' a b+clearPred v _ (p,l,s) = (filter ((/=v).snd) p,l,s) +updAdj :: Adj b -> (b -> Context' a b -> Context' a b) -> GraphRep a b -> GraphRep a b+updAdj adj f g = foldl' (\g' (l,v) -> M.adjust (f l) v g') g adj
LICENSE view
@@ -1,5 +1,6 @@ Copyright (c) 1999-2008, Martin Erwig               2010, Ivan Lazar Miljenovic+              2023, Troels Henriksen All rights reserved.  Redistribution and use in source and binary forms, with or without
+ fgl-arbitrary/Data/Graph/Inductive/Arbitrary.hs view
@@ -0,0 +1,359 @@+{-# 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 = case newNodes 1 g of+                   [] -> error "toConnGraph: cannot make node"+                   v:_ -> do+                     a <- arbitrary+                     ces <- concat <$> mapM (mkE v) ws+                     return $ CG { connNode     = v+                                 , connArbGraph = fromBaseGraph+                                                  . insEdges ces+                                                  . insNode (v,a)+                                                  $ g+                                 }+  where+    g = toBaseGraph ag++    ws = nodes g++    mkE v 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++-- -----------------------------------------------------------------------------
fgl.cabal view
@@ -1,42 +1,130 @@-name:		fgl-version:	5.4.2.3-license:	BSD3-license-file:	LICENSE-author:	        Martin Erwig, Ivan Lazar Miljenovic-maintainer:	Ivan.Miljenovic@gmail.com, tomberek@gmail.com-homepage:	http://web.engr.oregonstate.edu/~erwig/fgl/haskell-category:	Data Structures-synopsis:	Martin Erwig's Functional Graph Library-exposed-modules:-	Data.Graph.Inductive.Internal.FiniteMap,-	Data.Graph.Inductive.Internal.Heap,-	Data.Graph.Inductive.Internal.Queue,-	Data.Graph.Inductive.Internal.RootPath,-	Data.Graph.Inductive.Internal.Thread,-	Data.Graph.Inductive.Basic,-	Data.Graph.Inductive.Example,-	Data.Graph.Inductive.Graph,-	Data.Graph.Inductive.Graphviz,-	Data.Graph.Inductive.Monad,-	Data.Graph.Inductive.NodeMap,-    Data.Graph.Inductive.PatriciaTree,-	Data.Graph.Inductive.Query,-	Data.Graph.Inductive.Tree,-	Data.Graph.Inductive.Monad.IOArray,-	Data.Graph.Inductive.Query.ArtPoint,-	Data.Graph.Inductive.Query.BCC,-	Data.Graph.Inductive.Query.BFS,-	Data.Graph.Inductive.Query.DFS,-	Data.Graph.Inductive.Query.Dominators,-	Data.Graph.Inductive.Query.GVD,-	Data.Graph.Inductive.Query.Indep,-	Data.Graph.Inductive.Query.MST,-	Data.Graph.Inductive.Query.MaxFlow,-	Data.Graph.Inductive.Query.MaxFlow2,-	Data.Graph.Inductive.Query.Monad,-	Data.Graph.Inductive.Query.SP,-	Data.Graph.Inductive.Query.TransClos,-	Data.Graph.Inductive-build-depends:	base < 5, mtl, containers, array-extensions: MultiParamTypeClasses, OverlappingInstances, FlexibleInstances, ScopedTypeVariables-build-type: Simple+name:          fgl+version:       5.8.3.1+license:       BSD3+license-file:  LICENSE+author:        Martin Erwig, Ivan Lazar Miljenovic+maintainer:    athas@sigkill.dk+category:      Data Structures, Graphs+synopsis:      Martin Erwig's Functional Graph Library++description:+    An inductive representation of manipulating graph data structures.+    .+    Original website can be found at <http://web.engr.oregonstate.edu/~erwig/fgl/haskell>.+cabal-version: >= 1.10+build-type:    Simple+extra-source-files:+               ChangeLog++tested-with:   GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4,+               GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2,+               GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4,+               GHC == 9.10.3, GHC == 9.12.2++source-repository head+    type:         git+    location:     https://github.com/haskell/fgl.git++flag containers042+    manual:  False+    default: True++library+    default-language: Haskell98++    exposed-modules:+        Data.Graph.Inductive.Internal.Heap,+        Data.Graph.Inductive.Internal.Queue,+        Data.Graph.Inductive.Internal.RootPath,+        Data.Graph.Inductive.Internal.Thread,+        Data.Graph.Inductive.Basic,+        Data.Graph.Inductive.Example,+        Data.Graph.Inductive.Graph,+        Data.Graph.Inductive.Monad,+        Data.Graph.Inductive.NodeMap,+        Data.Graph.Inductive.PatriciaTree,+        Data.Graph.Inductive.Query,+        Data.Graph.Inductive.Tree,+        Data.Graph.Inductive.Monad.IOArray,+        Data.Graph.Inductive.Monad.STArray,+        Data.Graph.Inductive.Query.ArtPoint,+        Data.Graph.Inductive.Query.BCC,+        Data.Graph.Inductive.Query.BFS,+        Data.Graph.Inductive.Query.DFS,+        Data.Graph.Inductive.Query.Dominators,+        Data.Graph.Inductive.Query.GVD,+        Data.Graph.Inductive.Query.Indep,+        Data.Graph.Inductive.Query.MST,+        Data.Graph.Inductive.Query.MaxFlow,+        Data.Graph.Inductive.Query.MaxFlow2,+        Data.Graph.Inductive.Query.Monad,+        Data.Graph.Inductive.Query.SP,+        Data.Graph.Inductive.Query.TransClos,+        Data.Graph.Inductive++    other-modules:+        Paths_fgl++    build-depends:    base >= 4.3 && < 5+                    , transformers+                    , array++    if flag(containers042)+        build-depends:    containers >= 0.4.2+                        , deepseq >= 1.1.0.0 && < 1.6+    else+        build-depends:    containers < 0.4.2++    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.17+                    , hspec >= 2.1 && < 2.12+                    , 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+    if impl(ghc >= 8.0)+      ghc-options:    -Wall -Wno-star-is-type++benchmark fgl-benchmark+    if flag(containers042)+        buildable:    True+    else+        buildable:    False++    default-language: Haskell98++    type:             exitcode-stdio-1.0++    hs-source-dirs:   test++    main-is:          benchmark.hs++    other-modules:    Data.Graph.Inductive.Proxy++    build-depends:    fgl+                    , base+                    , microbench+                    , deepseq++    ghc-options:      -Wall
+ test/Data/Graph/Inductive/Graph/Properties.hs view
@@ -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+    ordr = 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' == ordr - 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 =+  case newNodes 1 g of+    [v] -> let vl = (v,l)+               g' = insNode vl g+           in gelem v g'+              && sort (labNodes g') == sort (vl : labNodes g)+              && sort (labEdges g') == sort (labEdges g)+              -- Note: not testing whether this changes+              -- nodeRange because newNodes /might/ return+              -- unused nodes in the middle.+    _ -> False++-- | Insert a node for every label in the list, but don't add any new+--   edges.+--+--   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 =+  case newNodes 2 g of+    [v,w] -> let g' = insNodes [(v,a1),(w,a2)] g+                 le = (v,w,b)+                 g'' = insEdges (replicate c le) g'+             in equal g' (delAllLEdge le g'')+    _ -> False++-- | There is a version of 'mkGraph' in its documentation that uses+--   'DynGraph' (hence why it isn't used by default).  This ensures+--   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)
+ test/Data/Graph/Inductive/Proxy.hs view
@@ -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
+ test/Data/Graph/Inductive/Query/Properties.hs view
@@ -0,0 +1,430 @@+{-# 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, group, (\\))+import           Data.Maybe    (fromJust, isJust, isNothing)+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 = describe "dom" $ do+  it "regular dom" $+    sortIt (dom domGraph 1) `shouldMatchList` [ (1, [1])+                                              , (2, [1,2])+                                              , (3, [1,2,3])+                                              , (4, [1,2,4])+                                              , (5, [1,2,5])+                                              , (6, [1,2,6])+                                              ]+  it "multiple components dom" $+    sortIt (dom domGraph1 1) `shouldMatchList` [ (1, [1])+                                               , (2, [1, 2])+                                               ]+  it "directed reachable components dom" $+    sortIt (dom domGraph2 1) `shouldMatchList` [ (1, [1]) ]++  it "unreachable nodes dom" $+    sortIt (dom domGraph3 1) `shouldMatchList` [(1,[1]), (2,[1,2])]++  where+    sortIt = map (second sort)++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)+                    ]++-- This graph has two components (independent subgraphs)+domGraph1 :: Gr () ()+domGraph1 = mkUGraph [1..3]+                     [ (1,2)+                     ]++-- This graph has no reachables from 1 (but 1 is reachable)+domGraph2 :: Gr () ()+domGraph2 = mkUGraph [1..3]+                     [ (2,1)+                     , (2,2)+                     ]++-- From #109: 1 -> 2 <- 3+domGraph3 :: Gr () ()+domGraph3 = mkUGraph [1..3] [(1,2), (3,2)]++-- -----------------------------------------------------------------------------+-- GVD++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. The shortest path algorithm is Dijkstra's,+    -- which doesn't support negative weights.+    g = emap getPositive (connGraph cg)++    gCon = emap (const 1) g `asTypeOf` g++               -- Length-based test+    test_p p = length p >= len_gCon+               && length (esp v w gCon) == len_gCon+               -- Weighting-based test+               && sum (map snd p) >= fromJust (spLength v w g)+      where+        v = fst (head p)+        w = fst (last p)++        len_gCon = length (fromJust $ sp v w gCon)++-- | Test that 'spLength' and 'sp' return a length and an connecting+--   path when destination is reachable from source.+test_sp_Just :: (ArbGraph gr, Graph gr, Real b) =>+  Proxy (gr a b) -> gr a b -> Property+test_sp_Just _ g =+  case nodes g of+    u:v:_ ->+      v `elem` bfs u g ==>+      isJust (spLength u v g) &&+      case sp u v g of+        Nothing -> False+        Just path ->+          not (null path) &&+          head path == u &&+          last path == v+    _ -> property True++-- | Test that 'spLength' and 'sp' return 'Nothing' when destination+--   is not reachable from source.+test_sp_Nothing :: (ArbGraph gr, Graph gr, Real b) =>+  Proxy (gr a b) -> gr a b -> Property+test_sp_Nothing _ g =+  case nodes g of+    u:v:_ ->+      not (v `elem` bfs u g) ==>+        isNothing (spLength u v g) &&+        isNothing (sp u v g)+    _ -> property True++-- -----------------------------------------------------------------------------+-- TransClos++-- | The transitive, reflexive closure of a graph means that every+-- node is a successor of itself, and also that if (a, b) is an edge,+-- and (b, c) is an edge, then (a, c) must also be an edge.+test_trc :: DynGraph gr => Proxy (gr a b) -> (NoMultipleEdges gr) a b -> Bool+test_trc _ nme = all valid $ nodes gTrans+  where+    g       = emap (const ()) (nmeGraph nme)+    gTrans  = trc g+    valid n =+      -- For each node n, check that:+      --   the successors for n in gTrans are a superset of the successors for n in g.+      null (suc g n \\ suc gTrans n) &&+      --   the successors for n in gTrans are exactly equal to the reachable nodes for n in g, plus n.+      sort (suc gTrans n) == map head (group (sort (n:[ v | u <- suc g n, v <- reachable u g ])))++-- | The transitive closure of a graph means that if (a, b) is an+-- edge, and (b, c) is an edge, then (a, c) must also be an edge.+test_tc :: DynGraph gr => Proxy (gr a b) -> (NoMultipleEdges gr) a b -> Bool+test_tc _ nme = all valid $ nodes gTrans+  where+    g       = nmeGraph nme+    gTrans  = tc g+    valid n =+      -- For each node n, check that:+      --   the successors for n in gTrans are a superset of the successors for n in g.+      null (suc g n \\ suc gTrans n) &&+      --   the successors for n in gTrans are exactly equal to the reachable nodes for n in g.+      sort (suc gTrans n) == map head (group (sort [ v | u <- suc g n, v <- reachable u g ]))++-- | The reflexive closure of a graph means that all nodes are a+-- successor of themselves.+test_rc :: DynGraph gr => Proxy (gr a b) -> gr a b -> Bool+test_rc _ g = and [ n `elem` suc gRefl n | n <- nodes gRefl ]+  where+    gRefl = rc g++-- -----------------------------------------------------------------------------+-- Utility functions++type UConnected gr a b = Connected (Undirected gr) a b
+ test/TestSuite.hs view
@@ -0,0 +1,134 @@+{-# 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+  describe "SP" $ do+    propP "sp"         test_sp+    propP "sp_Just"    test_sp_Just+    propP "sp_Nothing" test_sp_Nothing+  keepSmall $ do+    -- Just producing the sample graph to compare against is O(|V|^2)+    propP "trc"        test_trc+    propP "tc"         test_tc+    propP "rc"         test_rc+  where+    propP str = prop str . ($ p)++    p :: PatriciaTreeP+    p = Proxy++    keepSmall = modifyMaxSize (min 30)
+ test/benchmark.hs view
@@ -0,0 +1,173 @@+{-+  This program should generally be run using `cabal bench` or+  `stack bench`. To use `stack bench`, edit stack.yaml to include++  extra-deps:+  - microbench-0.1++  To run benchmarks manually, install microbench from+  http://hackage.haskell.org/cgi-bin/hackage-scripts/package/microbench++  then run++  % ghc -O --make benchmark+  % ./benchmark+  [1 of 1] Compiling Main             ( benchmark.hs, benchmark.o )+  Linking benchmark ...+  * insNode into AVL tree: ..................+    8.877ns per iteration / 112655.53 per second.+  * insNode into PATRICIA tree: .....................+    1.788ns per iteration / 559342.86 per second.+  * insEdge into AVL tree: ...........+    2833.029ns per iteration / 352.98 per second.+  * insEdge into PATRICIA tree: ...................+    4.625ns per iteration / 216224.60 per second.+  * gmap on AVL tree: ................+    32.754ns per iteration / 30530.57 per second.+  * gmap on PATRICIA tree: .....................+    1.623ns per iteration / 616056.37 per second.+  * nmap on AVL tree: ................+    35.455ns per iteration / 28204.95 per second.+  * nmap on PATRICIA tree: .....................+    1.713ns per iteration / 583758.06 per second.+  * emap on AVL tree: ...........+    4416.303ns per iteration / 226.43 per second.+  * emap on PATRICIA tree: ...................+    4.532ns per iteration / 220663.09 per second.+-}++{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import           Control.DeepSeq+import           Data.Graph.Inductive.Graph+import qualified Data.Graph.Inductive.PatriciaTree as Patricia+import           Data.Graph.Inductive.Proxy+import qualified Data.Graph.Inductive.Tree         as AVL+import           Microbench++main :: IO ()+main = do microbench "insNode into AVL tree" insNodeAVL+          microbench "insNode into PATRICIA tree" insNodePatricia++          microbench "buildFull into AVL tree 100" (buildFullAVL 100)+          microbench "buildFull into AVL tree 500" (buildFullAVL 500)+          microbench "buildFull into AVL tree 1000" (buildFullAVL 1000)++          microbench "buildFull into PATRICIA tree 100" (buildFullPatricia 100)+          microbench "buildFull into PATRICIA tree 500" (buildFullPatricia 500)+          microbench "buildFull into PATRICIA tree 1000" (buildFullPatricia 1000)++          microbench "insEdge into AVL tree" insEdgeAVL+          microbench "insEdge into PATRICIA tree" insEdgePatricia++          microbench "gmap on AVL tree" gmapAVL+          microbench "gmap on PATRICIA tree" gmapPatricia++          microbench "nmap on AVL tree" nmapAVL+          microbench "nmap on PATRICIA tree" nmapPatricia++          microbench "emap on AVL tree" emapAVL+          microbench "emap on PATRICIA tree" emapPatricia++buildFullAVL :: Int -> Int -> ()+buildFullAVL = buildFull (Proxy :: TreeP)++insNodeAVL :: Int -> AVL.UGr+insNodeAVL = insNodes' empty++buildFullPatricia :: Int -> Int -> ()+buildFullPatricia = buildFull (Proxy :: PatriciaTreeP)++insNodePatricia :: Int -> Patricia.UGr+insNodePatricia = insNodes' empty++buildFull :: forall gr . (DynGraph gr, NFData (gr Int ()))+             => GraphProxy gr -> Int -> Int -> ()+buildFull _ sz ntimes = rnf [buildFull' i (empty :: gr Int ()) 0 sz | i <- [0..ntimes-1]]++buildFull' :: DynGraph gr => a -> gr a () -> Int -> Int -> gr a ()+buildFull' a g n limit+  | n == limit = empty+  | otherwise = ([((), k) | k <- [0..n-1]],n,a,[((),k) | k <- [0..n-1]]) & buildFull' a g (n + 1) limit+++{-# INLINE insNodes' #-}+insNodes' :: DynGraph gr => gr () b -> Int -> gr () b+insNodes' g 0 = g+insNodes' g n = let [v] = newNodes 1 g+                    g'  = insNode (v, ()) g+                in+                  insNodes' g' (n - 1)+++insEdgeAVL :: Int -> AVL.UGr+insEdgeAVL n = insEdges' (insNodeAVL n) n+++insEdgePatricia :: Int -> Patricia.UGr+insEdgePatricia n = insEdges' (insNodePatricia n) n+++{-# INLINE insEdges' #-}+insEdges' :: DynGraph gr => gr a () -> Int -> gr a ()+insEdges' g 0 = g+insEdges' g n = let n' = n - 1+                    g' = insEdge (0, n', ()) g+                in+                  insEdges' g' n'+++gmapAVL :: Int -> AVL.Gr Int ()+gmapAVL n+    = let g  = insNodeAVL n+          g' = gmap f g+          f (ps, v, _, ss) = (ps, v, v, ss)+      in+        g'+++gmapPatricia :: Int -> Patricia.Gr Int ()+gmapPatricia n+    = let g  = insNodePatricia n+          g' = gmap f g+          f (ps, v, _, ss) = (ps, v, v, ss)+      in+        g'+++nmapAVL :: Int -> AVL.Gr Int ()+nmapAVL n+    = let g   = insNodeAVL n+          g'  = nmap f g+          f _ = n+      in+        g'+++nmapPatricia :: Int -> Patricia.Gr Int ()+nmapPatricia n+    = let g   = insNodePatricia n+          g'  = nmap f g+          f _ = n+      in+        g'+++emapAVL :: Int -> AVL.Gr () Int+emapAVL n+    = let g   = insEdgeAVL n+          g'  = emap f g+          f _ = n+      in+        g'+++emapPatricia :: Int -> Patricia.Gr () Int+emapPatricia n+    = let g   = insEdgePatricia n+          g'  = emap f g+          f _ = n+      in+        g'