fgl-5.5.4.0/0000755000000000000000000000000013142557523010630 5ustar0000000000000000fgl-5.5.4.0/LICENSE0000644000000000000000000000277613142557523011651 0ustar0000000000000000Copyright (c) 1999-2008, Martin Erwig 2010, Ivan Lazar Miljenovic All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. fgl-5.5.4.0/Setup.hs0000644000000000000000000000012713142557523012264 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain fgl-5.5.4.0/ChangeLog0000644000000000000000000001760613142557523012414 0ustar00000000000000005.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 fgl-5.5.4.0/fgl.cabal0000644000000000000000000000677213142557523012400 0ustar0000000000000000name: fgl version: 5.5.4.0 license: BSD3 license-file: LICENSE author: Martin Erwig, Ivan Lazar Miljenovic maintainer: Ivan.Miljenovic@gmail.com 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 . } cabal-version: >= 1.10 build-type: Simple extra-source-files: ChangeLog tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1, GHC == 8.1.* 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 < 5 , transformers , array if flag(containers042) build-depends: containers >= 0.4.2 , deepseq >= 1.1.0.0 && < 1.5 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.10 , hspec >= 2.1 && < 2.5 , 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 } 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 } fgl-5.5.4.0/fgl-arbitrary/0000755000000000000000000000000013142557523013375 5ustar0000000000000000fgl-5.5.4.0/fgl-arbitrary/Data/0000755000000000000000000000000013142557523014246 5ustar0000000000000000fgl-5.5.4.0/fgl-arbitrary/Data/Graph/0000755000000000000000000000000013142557523015307 5ustar0000000000000000fgl-5.5.4.0/fgl-arbitrary/Data/Graph/Inductive/0000755000000000000000000000000013142557523017241 5ustar0000000000000000fgl-5.5.4.0/fgl-arbitrary/Data/Graph/Inductive/Arbitrary.hs0000644000000000000000000002747513142557523021553 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- | Module : Data.Graph.Inductive.Arbitrary Description : Arbitrary definition for fgl graphs Copyright : (c) Ivan Lazar Miljenovic License : BSD3 Maintainer : Ivan.Miljenovic@gmail.com This module provides default definitions for use with QuickCheck's 'Arbitrary' class. Both "Data.Graph.Inductive.Tree"- and "Data.Graph.Inductive.PatriciaTree"-based graph implementations have 'Arbitrary' instances. In most cases, this is all you will need. If, however, you want to create arbitrary custom graph-like data structures, then you will probably want to do some custom processing from an arbitrary 'GraphNodesEdges' value, either directly or with a custom 'ArbGraph' instance. -} module Data.Graph.Inductive.Arbitrary ( -- * Explicit graph creation -- $explicit arbitraryGraph , arbitraryGraphWith , shrinkGraph , shrinkGraphWith -- * Types of graphs , ArbGraph(..) , GrProxy(..) , shrinkF , arbitraryGraphBy -- ** Specific graph structures , NoMultipleEdges(..) , NoLoops(..) , SimpleGraph , Undirected(..) -- ** Connected graphs , Connected(..) , connGraph -- * Node and edge lists , arbitraryNodes , arbitraryEdges , GraphNodesEdges(..) ) where import Data.Graph.Inductive.Graph (DynGraph, Graph, LEdge, LNode, Node, delNode, insEdges, insNode, mkGraph, newNodes, nodes, toEdge) import qualified Data.Graph.Inductive.PatriciaTree as P import qualified Data.Graph.Inductive.Tree as T import Test.QuickCheck (Arbitrary (..), Gen, elements, listOf) import Control.Applicative (liftA3) import Control.Arrow (second) import Data.Function (on) import Data.List (deleteBy, groupBy, sortBy) import Data.Maybe (mapMaybe) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif -- ----------------------------------------------------------------------------- -- | Generally a list of labelled nodes. arbitraryNodes :: (Arbitrary a) => Gen [LNode a] arbitraryNodes = arbitrary >>= mapM ((<$> arbitrary) . (,)) . uniq -- | Given a specified list of nodes, generate a list of edges. arbitraryEdges :: (Arbitrary b) => [LNode a] -> Gen [LEdge b] arbitraryEdges lns | null lns = return [] | otherwise = listOf (liftA3 (,,) nGen nGen arbitrary) where nGen = elements (map fst lns) -- | Defined so as to be able to generate valid 'arbitrary' node and -- edge lists. -- -- If any specific structure (no multiple edges, no loops, etc.) is -- required then you will need to post-process this after generating -- it, or else create a new instance of 'ArbGraph'. data GraphNodesEdges a b = GNEs { graphNodes :: [LNode a] , graphEdges :: [LEdge b] } deriving (Eq, Ord, Show, Read) instance (Arbitrary a, Arbitrary b) => Arbitrary (GraphNodesEdges a b) where arbitrary = do ns <- arbitraryNodes GNEs ns <$> arbitraryEdges ns shrink (GNEs ns es) = case ns of _:_:_ -> map delN ns _ -> [] where delN ln@(n,_) = GNEs ns' es' where ns' = deleteBy ((==)`on`fst) ln ns es' = filter (not . hasN) es hasN (v,w,_) = v == n || w == n -- ----------------------------------------------------------------------------- -- | Representation of generating arbitrary graph structures. -- -- Typically, you would only use this for the 'toBaseGraph' function -- or if you wanted to make a custom graph wrapper. -- -- The intent of this class is to simplify defining and using -- different wrappers on top of graphs (e.g. you may wish to have an -- 'Undirected' graph, or one with 'NoLoops', or possibly both!). class (DynGraph (BaseGraph ag)) => ArbGraph ag where type BaseGraph ag :: * -> * -> * toBaseGraph :: ag a b -> BaseGraph ag a b fromBaseGraph :: BaseGraph ag a b -> ag a b -- | Any manipulation of edges that should be done to satisfy the -- requirements of the specified wrapper. edgeF :: GrProxy ag -> [LEdge b] -> [LEdge b] -- | Shrinking function (assuming only one node is removed at a -- time) which also returns the node that is removed. shrinkFWith :: ag a b -> [(Node, ag a b)] -- | In most cases, for an instance of 'ArbGraph' the 'Arbitrary' -- instance definition will\/can have @shrink = shrinkF@. shrinkF :: (ArbGraph ag) => ag a b -> [ag a b] shrinkF = map snd . shrinkFWith instance ArbGraph T.Gr where type BaseGraph T.Gr = T.Gr toBaseGraph = id fromBaseGraph = id edgeF _ = id shrinkFWith = shrinkGraphWith instance ArbGraph P.Gr where type BaseGraph P.Gr = P.Gr toBaseGraph = id fromBaseGraph = id edgeF _ = id shrinkFWith = shrinkGraphWith -- | A simple graph-specific proxy type. data GrProxy (gr :: * -> * -> *) = GrProxy deriving (Eq, Ord, Show, Read) -- ----------------------------------------------------------------------------- {- $explicit If you wish to explicitly create a generated graph value (rather than using the 'Arbitrary' class) then you will want to use these functions. -} -- | Generate an arbitrary graph. Multiple edges are allowed. arbitraryGraph :: (Graph gr, Arbitrary a, Arbitrary b) => Gen (gr a b) arbitraryGraph = arbitraryGraphWith id -- | Generate an arbitrary graph, using the specified function to -- manipulate the generated list of edges (e.g. remove multiple -- edges). arbitraryGraphWith :: (Graph gr, Arbitrary a, Arbitrary b) => ([LEdge b] -> [LEdge b]) -> Gen (gr a b) arbitraryGraphWith f = do GNEs ns es <- arbitrary let es' = f es return (mkGraph ns es') -- | Generate an instance of 'ArbGraph' using the class methods. arbitraryGraphBy :: forall ag a b. (ArbGraph ag, Arbitrary a, Arbitrary b) => Gen (ag a b) arbitraryGraphBy = fromBaseGraph <$> arbitraryGraphWith (edgeF (GrProxy :: GrProxy ag)) -- Ensure we have a list of unique Node values; this will also sort -- the list, but that shouldn't matter. uniq :: [Node] -> [Node] uniq = uniqBy id uniqBy :: (Ord b) => (a -> b) -> [a] -> [a] uniqBy f = map head . groupBy ((==) `on` f) . sortBy (compare `on` f) -- | For a graph with at least two nodes, return every possible way of -- deleting a single node (i.e. will never shrink to an empty -- graph). shrinkGraph :: (Graph gr) => gr a b -> [gr a b] shrinkGraph = map snd . shrinkGraphWith -- | As with 'shrinkGraph', but also return the node that was deleted. shrinkGraphWith :: (Graph gr) => gr a b -> [(Node, gr a b)] shrinkGraphWith gr = case nodes gr of -- Need to have at least 2 nodes before we delete one! ns@(_:_:_) -> map ((,) <*> (`delNode` gr)) ns _ -> [] instance (Arbitrary a, Arbitrary b) => Arbitrary (T.Gr a b) where arbitrary = arbitraryGraph shrink = shrinkGraph instance (Arbitrary a, Arbitrary b) => Arbitrary (P.Gr a b) where arbitrary = arbitraryGraph shrink = shrinkGraph -- | A newtype wrapper to generate a graph without multiple edges -- (loops allowed). newtype NoMultipleEdges gr a b = NME { nmeGraph :: gr a b } deriving (Eq, Show, Read) instance (ArbGraph gr) => ArbGraph (NoMultipleEdges gr) where type BaseGraph (NoMultipleEdges gr) = BaseGraph gr toBaseGraph = toBaseGraph. nmeGraph fromBaseGraph = NME . fromBaseGraph edgeF _ = uniqBy toEdge . edgeF (GrProxy :: GrProxy gr) shrinkFWith = map (second NME) . shrinkFWith . nmeGraph instance (ArbGraph gr, Arbitrary a, Arbitrary b) => Arbitrary (NoMultipleEdges gr a b) where arbitrary = arbitraryGraphBy shrink = shrinkF -- | A newtype wrapper to generate a graph without loops (multiple -- edges allowed). newtype NoLoops gr a b = NL { looplessGraph :: gr a b } deriving (Eq, Show, Read) instance (ArbGraph gr) => ArbGraph (NoLoops gr) where type BaseGraph (NoLoops gr) = BaseGraph gr toBaseGraph = toBaseGraph . looplessGraph fromBaseGraph = NL . fromBaseGraph edgeF _ = filter notLoop . edgeF (GrProxy :: GrProxy gr) shrinkFWith = map (second NL) . shrinkFWith . looplessGraph notLoop :: LEdge b -> Bool notLoop (v,w,_) = v /= w instance (ArbGraph gr, Arbitrary a, Arbitrary b) => Arbitrary (NoLoops gr a b) where arbitrary = arbitraryGraphBy shrink = shrinkF -- | A wrapper to generate a graph without multiple edges and -- no loops. type SimpleGraph gr = NoLoops (NoMultipleEdges gr) -- | A newtype wrapper such that each (non-loop) edge also has its -- reverse in the graph. -- -- Note that there is no way to guarantee this after any additional -- edges are added or removed. -- -- You should also apply this wrapper /after/ 'NoMultipleEdges' or -- else the wrong reverse edge might be removed. newtype Undirected gr a b = UG { undirGraph :: gr a b } deriving (Eq, Show, Read) instance (ArbGraph gr) => ArbGraph (Undirected gr) where type BaseGraph (Undirected gr) = BaseGraph gr toBaseGraph = toBaseGraph . undirGraph fromBaseGraph = UG . fromBaseGraph edgeF _ = undirect . edgeF (GrProxy :: GrProxy gr) shrinkFWith = map (second UG) . shrinkFWith . undirGraph undirect :: [LEdge b] -> [LEdge b] undirect = concatMap undir where undir le@(v,w,b) | notLoop le = [le, (w,v,b)] | otherwise = [le] instance (ArbGraph gr, Arbitrary a, Arbitrary b) => Arbitrary (Undirected gr a b) where arbitrary = arbitraryGraphBy shrink = shrinkF -- ----------------------------------------------------------------------------- -- | A brute-force approach to generating connected graphs. -- -- The resultant graph (obtained with 'connGraph') will /never/ be -- empty: it will, at the very least, contain an additional -- connected node (obtained with 'connNode'). -- -- Note that this is /not/ an instance of 'ArbGraph' as it is not -- possible to arbitrarily layer a transformer on top of this. data Connected ag a b = CG { connNode :: Node , connArbGraph :: ag a b } deriving (Eq, Show, Read) instance (ArbGraph ag, Arbitrary a, Arbitrary b) => Arbitrary (Connected ag a b) where arbitrary = arbitraryGraphBy >>= toConnGraph shrink = shrinkConnGraph toConnGraph :: forall ag a b. (ArbGraph ag, Arbitrary a, Arbitrary b) => ag a b -> Gen (Connected ag a b) toConnGraph ag = do a <- arbitrary ces <- concat <$> mapM mkE ws return $ CG { connNode = v , connArbGraph = fromBaseGraph . insEdges ces . insNode (v,a) $ g } where g = toBaseGraph ag [v] = newNodes 1 g ws = nodes g mkE w = do b <- arbitrary return (edgeF p [(v,w,b)]) p :: GrProxy ag p = GrProxy shrinkConnGraph :: (ArbGraph ag) => Connected ag a b -> [Connected ag a b] shrinkConnGraph cg = mapMaybe keepConn . shrinkFWith $ g where v = connNode cg g = connArbGraph cg keepConn (w,sgs) | v == w = Nothing | otherwise = Just (cg { connArbGraph = sgs }) -- | The underlying graph represented by this 'Connected' value. connGraph :: (ArbGraph ag) => Connected ag a b -> BaseGraph ag a b connGraph = toBaseGraph . connArbGraph -- ----------------------------------------------------------------------------- fgl-5.5.4.0/test/0000755000000000000000000000000013142557523011607 5ustar0000000000000000fgl-5.5.4.0/test/benchmark.hs0000644000000000000000000001166513142557523014106 0ustar0000000000000000{- 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' fgl-5.5.4.0/test/TestSuite.hs0000644000000000000000000001113513142557523014075 0ustar0000000000000000{-# 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) fgl-5.5.4.0/test/Data/0000755000000000000000000000000013142557523012460 5ustar0000000000000000fgl-5.5.4.0/test/Data/Graph/0000755000000000000000000000000013142557523013521 5ustar0000000000000000fgl-5.5.4.0/test/Data/Graph/Inductive/0000755000000000000000000000000013142557523015453 5ustar0000000000000000fgl-5.5.4.0/test/Data/Graph/Inductive/Proxy.hs0000644000000000000000000000231213142557523017126 0ustar0000000000000000{- | 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 fgl-5.5.4.0/test/Data/Graph/Inductive/Query/0000755000000000000000000000000013142557523016560 5ustar0000000000000000fgl-5.5.4.0/test/Data/Graph/Inductive/Query/Properties.hs0000644000000000000000000003343513142557523021260 0ustar0000000000000000{-# 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 = it "dom" $ sortIt (dom domGraph 1) `shouldMatchList` [ (1, [1]) , (2, [1,2]) , (3, [1,2,3]) , (4, [1,2,4]) , (5, [1,2,5]) , (6, [1,2,6]) ] where sortIt = map (second sort) test_iDom :: Spec test_iDom = it "iDom" $ iDom domGraph 1 `shouldMatchList` [(2,1),(3,2),(4,2),(5,2),(6,2)] -- Taken from domGraph :: Gr () () domGraph = mkUGraph [1..6] [ (1,2) , (2,3) , (2,4) , (2,6) , (3,5) , (4,5) , (5,2) ] -- ----------------------------------------------------------------------------- -- GVD test_voronoiSet :: Spec test_voronoiSet = describe "voronoiSet" $ do describe "inwards" $ do it "with root node" (voronoiSet 4 vd `shouldMatchList` [1,2,4]) it "other node" (voronoiSet 1 vd `shouldSatisfy` null) describe "outwards" $ do it "with root node" (voronoiSet 4 vd0 `shouldMatchList` [2,4,6,7]) it "other node" (voronoiSet 1 vd0 `shouldSatisfy` null) test_nearestNode :: Spec test_nearestNode = describe "nearestNode" $ do describe "inwards" $ do it "reachable" (nearestNode 6 vd `shouldBe` Just 5) it "unreachable" (nearestNode 7 vd `shouldBe` Nothing) describe "outwards" $ do it "reachable" (nearestNode 6 vd0 `shouldBe` Just 4) it "unreachable" (nearestNode 1 vd0 `shouldBe` Nothing) test_nearestDist :: Spec test_nearestDist = describe "nearestDist" $ do describe "inwards" $ do it "root" (nearestDist 4 vd `shouldBe` Just 0) it "reachable" (nearestDist 1 vd `shouldBe` Just 3) it "unreachable" (nearestDist 7 vd `shouldBe` Nothing) describe "outwards" $ do it "root" (nearestDist 5 vd0 `shouldBe` Just 0) it "reachable" (nearestDist 7 vd0 `shouldBe` Just 4) it "unreachable" (nearestDist 1 vd0 `shouldBe` Nothing) test_nearestPath :: Spec test_nearestPath = describe "nearestPath" $ do describe "inwards" $ do it "reachable" (nearestPath 1 vd `shouldBe` Just [1,4]) it "unreachable" (nearestPath 7 vd `shouldBe` Nothing) describe "outwards" $ do it "reachable" (nearestPath 7 vd0 `shouldBe` Just [7,6,4]) it "unreachable" (nearestPath 1 vd0 `shouldBe` Nothing) vd :: Voronoi Int vd = gvdIn [4,5] vor vd0 :: Voronoi Int vd0 = gvdOut [4,5] vor -- ----------------------------------------------------------------------------- -- Indep -- TODO: how to prove that the found independent set is /maximal/? -- | Make sure the size of independent sets is indeed accurate. test_indepSize :: (ArbGraph gr) => Proxy (gr a b) -> gr a b -> Bool test_indepSize _ ag = uncurry ((==) . length) (indepSize g) where g = toBaseGraph ag -- | Is this really an independent set? test_indep :: (ArbGraph gr) => Proxy (gr a b) -> gr a b -> Bool test_indep _ ag = and . unfoldr checkSet . S.fromList $ indep g where g = toBaseGraph ag checkSet = fmap checkVal . S.minView checkVal (v,ws) = (S.null (S.fromList (neighbors g v) `S.intersection` ws), ws) -- ----------------------------------------------------------------------------- -- MaxFlow2 -- As it is difficult to generate a suitable arbitrary graph for which -- there /is/ a valid flow, we instead use unit tests based upon the -- examples in the source code. -- | Maximum flow of 2000 exampleNetwork1 :: Network exampleNetwork1 = emap (flip (,) 0 . fromIntegral) exampleFlowGraph1 -- | Taken from "Introduction to Algorithms" (Cormen, Leiserson, Rivest). -- This network has a maximum flow of 23 exampleNetwork2 :: Network -- Names of nodes in "Introduction to Algorithms": -- 1: s -- 2: v1 -- 3: v2 -- 4: v3 -- 5: v4 -- 6: t exampleNetwork2 = nemap (const ()) (flip (,) 0 . fromIntegral) clr595 clr595_network :: Network clr595_network = maxFlowgraph clr595' 1 6 where clr595' = nemap (const ()) fromIntegral clr595 test_maxFlow2_with :: String -> (Network -> Node -> Node -> (Network,Double)) -> Spec test_maxFlow2_with nm f = it nm $ do snd (f exampleNetwork1 1 4) `shouldBe` 2000 snd (f exampleNetwork2 1 6) `shouldBe` 23 test_maxFlow2 :: Spec test_maxFlow2 = describe "MaxFlow2" $ do test_maxFlow2_with "ekSimple" ekSimple test_maxFlow2_with "ekFused" ekFused test_maxFlow2_with "ekList" ekList -- ----------------------------------------------------------------------------- -- MaxFlow -- TODO: test other exported functions. exampleFlowGraph1 :: Gr () Int exampleFlowGraph1 = mkGraph [ (1,()), (2,()), (3,()), (4,()) ] [ (1,2,1000), (1,3,1000) , (2,3,1), (2,4,1000), (3,4,1000) ] test_maxFlow :: Spec test_maxFlow = it "maxFlow" $ do maxFlow exampleFlowGraph1 1 4 `shouldBe` 2000 maxFlow clr595 1 6 `shouldBe` 23 -- ----------------------------------------------------------------------------- -- MST -- | A minimum spanning tree of a connected, undirected graph should -- cover all nodes, and all edges in the tree should be present in -- the original graph. test_msTree :: (ArbGraph gr) => Proxy (gr a b) -> UConnected gr () Int -> Bool test_msTree _ cg = ns == mstNs && S.isSubsetOf mstEs es where g = connGraph cg -- a Connected graph is always non-empty mst = map unLPath (msTree g) ns = S.fromList (nodes g) es = S.fromList (labEdges g) mstNs = S.unions (map (S.fromList . map fst) mst) mstEs = S.unions (map (S.fromList . (zipWith toE <*> tail)) mst) toE (w,l) (v,_) = (v,w,l) -- ----------------------------------------------------------------------------- -- SP test_sp :: (ArbGraph gr) => Proxy (gr a b) -> UConnected gr () (Positive Int) -> Bool test_sp _ cg = all test_p (map unLPath (msTree g)) where -- Use Positive to avoid problems with distances containing -- negative lengths. 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 = (noNodes g >= 2 && v `elem` bfs u g) ==> isJust (spLength u v g) && isJust maybePath && not (null path) && head path == u && last path == v where [u,v] = take 2 (nodes g) maybePath@(Just path) = sp u v g -- | Test that 'spLength' and 'sp' return 'Nothing' when destination -- is not reachable from source. test_sp_Nothing :: (ArbGraph gr, Graph gr, Real b) => Proxy (gr a b) -> gr a b -> Property test_sp_Nothing _ g = (noNodes g >= 2 && not (v `elem` bfs u g)) ==> isNothing (spLength u v g) && isNothing (sp u v g) where [u,v] = take 2 (nodes g) -- ----------------------------------------------------------------------------- -- 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 fgl-5.5.4.0/test/Data/Graph/Inductive/Graph/0000755000000000000000000000000013142557523016514 5ustar0000000000000000fgl-5.5.4.0/test/Data/Graph/Inductive/Graph/Properties.hs0000644000000000000000000003665213142557523021220 0ustar0000000000000000{-# 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 = gelem v g' && sort (labNodes g') == sort (vl : labNodes g) && sort (labEdges g') == sort (labEdges g) -- Note: not testing whether this changes -- nodeRange because newNodes /might/ return -- unused nodes in the middle. where [v] = newNodes 1 g vl = (v,l) g' = insNode vl g -- | Insert a node for every label in the list, but don't add any new -- edges. -- -- Note that we specifically use 'newNodes' to test this, as the -- current behaviour is to throw an error if an existing node is -- used. valid_insNodes :: (DynGraph gr, Ord a, Ord b) => gr a b -> [a] -> Bool valid_insNodes g as = all (`gelem`g') ns && sort (labNodes g') == sort (lns ++ labNodes g) && sort (labEdges g') == sort (labEdges g) where c = length as ns = newNodes c g lns = zip ns as g' = insNodes lns g -- | Test inserting an edge. This could possibly be a multiple edge -- or loop. valid_insEdge :: (DynGraph gr, Ord a, Ord b) => gr a b -> b -> Property valid_insEdge g b = not (isEmpty g) ==> do v <- pickN w <- pickN let el = (v,w,b) g' = insEdge el g return ( sort (labEdges g') == sort (el : labEdges g) && sort (labNodes g') == sort (labNodes g)) where pickN = elements (nodes g) -- | Insert an edge for every label in the list. Multiple edges and -- loops allowed. valid_insEdges :: (DynGraph gr, Ord a, Ord b) => gr a b -> [b] -> Property valid_insEdges g bs = not (isEmpty g) ==> do es <- mapM toLE bs let g' = insEdges es g return ( sort (labEdges g') == sort (es ++ labEdges g) && sort (labNodes g') == sort (labNodes g)) where pickN = elements (nodes g) toLE b = do v <- pickN w <- pickN return (v,w,b) -- | Explicitly test adding multiple edges. valid_insEdges_multiple :: (DynGraph gr, Ord b) => gr a b -> b -> NonNegative Int -> Property valid_insEdges_multiple g b (NonNegative c) = not (isEmpty g) ==> do v <- pickN w <- pickN let bes = replicate c (v,w,b) g' = insEdges bes g es' = bes ++ es return $ sort (labEdges g') == sort es' where pickN = elements (nodes g) es = labEdges g -- | Delete a node, and ensure there are no edges -- referencing that node afterwards. valid_delNode :: (DynGraph gr) => gr a b -> Node -> Bool valid_delNode g v = not (gelem v g') && (v `S.notMember` S.fromList (esToNs (labEdges g'))) where g' = delNode v g -- | Test deleting a sub-set of nodes. valid_delNodes :: (DynGraph gr) => gr a b -> [Node] -> Bool valid_delNodes g vs = all (liftA2 (&&) (not . (`gelem` g')) (`S.notMember` ens)) vs where g' = delNodes vs g ens = S.fromList (esToNs (labEdges g')) -- | Delete an edge, and ensure that the nodes from that -- edge are still there (if that edge was present in the graph to -- start with). valid_delEdge :: (DynGraph gr) => gr a b -> (Node,Node) -> Bool valid_delEdge g e@(v,w) = notElem e (edges g') && ifOrig v && ifOrig w where g' = delEdge e g ifOrig n = not (n `gelem` g) || (n `gelem` g') -- | Test deleting multiple edges. valid_delEdges :: (DynGraph gr) => gr a b -> [Edge] -> Bool valid_delEdges g es = all check_E es where origEs = S.fromList (edges g) g' = delEdges es g newEs = S.fromList (edges g') check_E e@(v,w) = (e `S.notMember` origEs) || ( (e `S.notMember` newEs) && (v `gelem` g') && (w `gelem` g') ) -- | Add a 'LEdge' then delete it; the resulting graph should be the -- same as the original graph. valid_delLEdge :: (DynGraph gr, Eq a, Eq b) => gr a b -> b -> Property valid_delLEdge g b = not (isEmpty g) ==> do v <- pickN w <- pickN let le = (v,w,b) g' = insEdge le g g'' = delLEdge le g' return (equal g g'') where pickN = elements (nodes g) -- | Test deleting all labelled edges equal to the specified one, by -- adding the specified number to the graph and then deleting them. valid_delAllLEdge :: (DynGraph gr, Eq a, Eq b) => gr a b -> NonNegative Int -> a -> a -> b -> Bool valid_delAllLEdge g (NonNegative c) a1 a2 b = equal g' (delAllLEdge le g'') where [v,w] = newNodes 2 g g' = insNodes [(v,a1),(w,a2)] g le = (v,w,b) g'' = insEdges (replicate c le) g' -- | There is a version of 'mkGraph' in its documentation that uses -- 'DynGraph' (hence why it isn't used by default). This ensures -- that the optimised variants match this \"default\" definition. valid_mkGraph :: (DynGraph gr, Eq a, Eq b) => Proxy (gr a b) -> GraphNodesEdges a b -> Bool valid_mkGraph p (GNEs ns es) = equal mkGr (mkGraph ns es) where mkGr = (insEdges es . insNodes ns) empty `asProxyTypeOf` p -- | 'buildGr' re-creates the original graph after 'ufold' obtains all -- the contexts. valid_buildGr :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool valid_buildGr g = equal g (buildGr cs) where cs = ufold (:) [] g -- | Tests `gfiltermap` with a function accepting all contexts. gfiltermap_id :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool gfiltermap_id g = equal (gfiltermap Just g) g -- | Tests `nfilter` with a function accepting all nodes. nfilter_true :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool nfilter_true g = equal (nfilter (const True) g) g -- | Tests `labnfilter` with a function accepting all nodes. labnfilter_true :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool labnfilter_true g = equal (labnfilter (const True) g) g -- | Tests `labnfilter` with a function accepting all nodes. labfilter_true :: (DynGraph gr, Eq a, Eq b) => gr a b -> Bool labfilter_true g = equal (labfilter (const True) g) g -- | The subgraph induced by a list of nodes should contain exactly -- the nodes from this list, as well as all edges between these nodes. valid_subgraph :: (DynGraph gr, Ord b) => gr a b -> Gen Bool valid_subgraph gr = do vs <- sublistOf $ nodes gr let sg = subgraph vs gr svs = S.fromList vs subedges = filter (\(v,w,_) -> v `S.member` svs && w `S.member` svs) $ labEdges gr return $ sort (nodes sg) == sort vs && sort (labEdges sg) == sort subedges -- ----------------------------------------------------------------------------- -- Miscellaneous -- | Ensure the edge projection functions work as intended. edge_projections :: (Eq b) => LEdge b -> Bool edge_projections le = le == toLEdge (toEdge le) (edgeLabel le) -- ----------------------------------------------------------------------------- esToNs :: [LEdge b] -> [Node] esToNs = uniqBy id . concatMap (\(v,w,_) -> [v,w]) uniqBy :: (Ord b) => (a -> b) -> [a] -> [a] uniqBy f = map head . groupBy ((==) `on` f) . sortOn f sortOn :: (Ord b) => (a -> b) -> [a] -> [a] sortOn f = sortBy (compare `on` f) -- | As with suc', but also remove any loops sucC :: Context a b -> [Node] sucC c = filter (/= node' c) (suc' c) -- | As with pre', but also remove any loops preC :: Context a b -> [Node] preC c = filter (/= node' c) (pre' c) -- In case a Context is produced with the Adj lists in different -- orders, sort them so that they can then be equality tested. sortContext :: (Ord b) => Context a b -> Context a b sortContext (p,v,l,s) = (sort p, v, l, sort s) fgl-5.5.4.0/Data/0000755000000000000000000000000013142557523011501 5ustar0000000000000000fgl-5.5.4.0/Data/Graph/0000755000000000000000000000000013142557523012542 5ustar0000000000000000fgl-5.5.4.0/Data/Graph/Inductive.hs0000644000000000000000000000165113142557523015033 0ustar0000000000000000------------------------------------------------------------------------------ -- -- Inductive.hs -- Functional Graph Library -- -- (c) 1999-2007 by Martin Erwig [see file COPYRIGHT] -- ------------------------------------------------------------------------------ module Data.Graph.Inductive ( module I -- * Version Information , version ) where 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, version " ++ showVersion Paths.version fgl-5.5.4.0/Data/Graph/Inductive/0000755000000000000000000000000013142557523014474 5ustar0000000000000000fgl-5.5.4.0/Data/Graph/Inductive/Monad.hs0000644000000000000000000001555013142557523016074 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} -- (c) 2002 by Martin Erwig [see file COPYRIGHT] -- | Monadic Graphs module Data.Graph.Inductive.Monad( -- * Classes GraphM(..), -- * Operations -- ** Graph Folds and Maps ufoldM, -- ** Graph Projection nodesM,edgesM,newNodesM, -- ** Graph Construction and Destruction delNodeM,delNodesM, mkUGraphM, -- ** Graph Inspection contextM,labM ) where import Data.Graph.Inductive.Graph {-# ANN module "HLint: ignore Redundant lambda" #-} ---------------------------------------------------------------------- -- 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 {-# 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] matchAnyM :: m (gr a b) -> m (GDecomp gr a b) matchAnyM g = do vs <- labNodesM g case vs of [] -> fail "Match Exception, Empty Graph" (v,_):_ -> do (Just c,g') <- matchM v g return (c,g') noNodesM :: m (gr a b) -> m Int noNodesM = labNodesM >>. length nodeRangeM :: m (gr a b) -> m (Node,Node) nodeRangeM g = do isE <- isEmptyM g if isE then fail "nodeRangeM of empty graph" else do vs <- nodesM g return (minimum vs,maximum vs) labEdgesM :: m (gr a b) -> m [LEdge b] labEdgesM = ufoldM (\(p,v,_,s)->((map (i v) p ++ map (o v) s)++)) [] where o v = \(l,w)->(v,w,l) i v = \(l,w)->(w,v,l) -- composing a monadic function with a non-monadic one -- (>>.) :: (Monad m) => (m a -> m b) -> (b -> c) -> m a -> m c f >>. g = (>>= return . g) . f ---------------------------------------------------------------------- -- DERIVED GRAPH OPERATIONS ---------------------------------------------------------------------- -- graph folds and maps -- -- | graph fold 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 x <- ufoldM f u (return g') return (f c x) -- (additional) graph projection -- [noNodes, nodeRange, labNodes, labEdges are defined in class Graph] -- 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 = labEdgesM >>. map (\(v,w,_)->(v,w)) 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 v = delNodesM [v] delNodesM :: (GraphM m gr) => [Node] -> m (gr a b) -> m (gr a b) delNodesM [] g = g delNodesM (v:vs) g = do (_,g') <- matchM v g delNodesM vs (return g') mkUGraphM :: (GraphM m gr) => [Node] -> [Edge] -> m (gr () ()) mkUGraphM vs es = mkGraphM (labUNodes vs) (labUEdges es) 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 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 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 = onMatch (Just . lab') Nothing {- 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 = map snd .: context4 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 = map flip2 .: context4 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 g v = map (\(l,w)->(v,w,l)) (context4 g v) 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 = length .: context4 indeg :: (GraphM m gr) => m (gr a b) -> Node -> Int indeg = length .: context1 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' (p,_,_,s) = map snd p++map snd s -- -- suc' :: Context a b -> [Node] -- suc' (_,_,_,s) = map snd s -- -- pre' :: Context a b -> [Node] -- pre' (p,_,_,_) = map snd p -- -- 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' (_,v,_,s) = map (\(l,w)->(v,w,l)) s -- -- 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 n@(v,a) n'@(w,b) | n == n' = EQ | v m (gr a b) -> [LNode a] slabNodes = sortBy nodeComp . labNodes edgeComp :: (Eq b) => LEdge b -> LEdge b -> Ordering edgeComp e@(v,w,a) e'@(x,y,b) | e == e' = EQ | v m (gr a b) -> [LEdge b] slabEdges = sortBy edgeComp . labEdges instance (Eq a,Eq b,Graph gr) => Eq (m (gr a b)) where g == g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g' -} fgl-5.5.4.0/Data/Graph/Inductive/PatriciaTree.hs0000644000000000000000000002375713142557523017422 0ustar0000000000000000{-# 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"). -- -- This module provides the following specialised functions to gain -- more performance, using GHC's RULES pragma: -- -- * 'Data.Graph.Inductive.Graph.insNode' -- -- * 'Data.Graph.Inductive.Graph.insEdge' -- -- * 'Data.Graph.Inductive.Graph.gmap' -- -- * 'Data.Graph.Inductive.Graph.nmap' -- -- * 'Data.Graph.Inductive.Graph.emap' module Data.Graph.Inductive.PatriciaTree ( Gr , UGr ) where 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) #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 empty = Gr IM.empty isEmpty (Gr g) = IM.null g match = matchGr 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 ] noNodes (Gr g) = IM.size g 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 (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 #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 Nothing -> (Nothing, Gr g) Just (p, label, s) -> let !g1 = IM.delete node g !p' = IM.delete node p !s' = IM.delete node s !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 {-# 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 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 {-# 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) {-# 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) {-# 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 (:[]) . swap) data FromListCounting a = FromListCounting !Int !(IntMap a) deriving (Eq, Show, Read) 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 #-} 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) -- 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) swap :: (a, b) -> (b, a) swap (a, b) = (b, a) -- A version of @++@ where order isn't important, so @xs ++ [x]@ -- becomes @x:xs@. Used when we have to have a function of type @[a] -- -> [a] -> [a]@ but one of the lists is just going to be a single -- element (and it isn't possible to tell which). addLists :: [a] -> [a] -> [a] addLists [a] as = a : as addLists as [a] = a : as addLists xs ys = xs ++ ys 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 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 :: 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) fgl-5.5.4.0/Data/Graph/Inductive/Graph.hs0000644000000000000000000005052213142557523016075 0ustar0000000000000000{-# LANGUAGE CPP #-} -- (c) 1999-2005 by Martin Erwig [see file COPYRIGHT] -- | Static and Dynamic Inductive Graphs module Data.Graph.Inductive.Graph ( -- * General Type Defintions -- ** Node and Edge Types Node,LNode,UNode, Edge,LEdge,UEdge, -- ** Types Supporting Inductive Graph View Adj,Context,MContext,Decomp,GDecomp,UContext,UDecomp, Path,LPath(..),UPath, -- * Graph Type Classes -- | We define two graph classes: -- -- Graph: static, decomposable graphs. -- 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. -- -- 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 -- nodes can be easily derived from labNodes, but not vice versa. Graph(..), DynGraph(..), -- * Operations order, size, -- ** Graph Folds and Maps ufold,gmap,nmap,emap,nemap, -- ** Graph Projection nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem, -- ** Graph Construction and Destruction insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge, insNodes,insEdges,delNodes,delEdges, buildGr,mkUGraph, -- ** Subgraphs gfiltermap,nfilter,labnfilter,labfilter,subgraph, -- ** Graph Inspection context,lab,neighbors,lneighbors, suc,pre,lsuc,lpre, out,inn,outdeg,indeg,deg, hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj, equal, -- ** Context Inspection node',lab',labNode',neighbors',lneighbors', suc',pre',lpre',lsuc', out',inn',outdeg',indeg',deg', -- * Pretty-printing prettify, prettyPrint, -- * Ordering of Graphs OrdGr(..) ) where 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 -- | Labeled node type LNode a = (Node,a) -- | Quasi-unlabeled node type UNode = LNode () -- | Unlabeled edge type Edge = (Node,Node) -- | Labeled edge type LEdge b = (Node,Node,b) -- | Quasi-unlabeled edge type UEdge = LEdge () -- | Unlabeled path type Path = [Node] -- | Labeled path newtype LPath a = LP { unLPath :: [LNode a] } 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] -- | 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 -- of the 'Graph'. type Decomp g a b = (MContext a b,g a b) -- | The same as 'Decomp', only more sure of itself. type GDecomp g a b = (Context a b,g a b) -- | Unlabeled context. type UContext = ([Node],Node,[Node]) -- | Unlabeled decomposition. type UDecomp g = (Maybe UContext,g) -- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes' class Graph gr where {-# 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] -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node' -- and the remaining 'Graph'. matchAny :: gr a b -> GDecomp gr a b matchAny g = case labNodes g of [] -> error "Match Exception, Empty Graph" (v,_):_ -> (c,g') where (Just c,g') = match v g -- | The number of 'Node's in a 'Graph'. noNodes :: gr a b -> Int noNodes = length . labNodes -- | The minimum and maximum 'Node' in a 'Graph'. nodeRange :: gr a b -> (Node,Node) nodeRange g | isEmpty g = error "nodeRange of empty graph" | otherwise = (minimum vs, maximum vs) where vs = nodes g -- | A list of all 'LEdge's in the 'Graph'. labEdges :: gr a b -> [LEdge b] labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) [] 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 -- | The number of nodes in the graph. An alias for 'noNodes'. order :: (Graph gr) => gr a b -> Int order = noNodes -- | 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 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 f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s)) 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 = map fst . labNodes -- | List all 'Edge's in the 'Graph'. 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 | 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 = isJust . fst . match v -- | Insert a 'LNode' into the 'Graph'. 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 (v,w,l) g = (pr,v,la,(l,w):su) & 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 v = delNodes [v] -- | Remove an 'Edge' from the 'Graph'. -- -- 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' -- | 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 = 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 = 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 = 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 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 = foldl' (flip delEdge) g es -- | Build a 'Graph' from a list of 'Context's. -- -- 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 -- | Build a quasi-unlabeled 'Graph'. 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 = 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 = fmap lab' . fst $ match v g -- | Find the neighbors for a 'Node'. 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 = map snd .: context4l -- | Find all 'Node's that link to to the given '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 = 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 = map flip2 .: context1l -- | Find all outward-bound 'LEdge's for the given 'Node'. 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 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 = length .: context4l -- | The inward-bound degree of the 'Node'. 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 = deg' .: context -- | The 'Node' in a 'Context'. node' :: Context a b -> Node node' (_,v,_,_) = v -- | The label in a 'Context'. lab' :: Context a b -> a lab' (_,_,l,_) = l -- | The 'LNode' from a 'Context'. labNode' :: Context a b -> LNode a labNode' (_,v,l,_) = (v,l) -- | All 'Node's linked to or from in a 'Context'. 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' = map snd . context1l' -- | All 'Node's linked from in a 'Context', and the label of the links. lsuc' :: Context a b -> [(Node,b)] 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' = map flip2 . context1l' -- | All outward-directed 'LEdge's in a 'Context'. 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' c@(_,v,_,_) = map (\(l,w)->(w,v,l)) (context1l' c) -- | The outward degree of a 'Context'. outdeg' :: Context a b -> Int outdeg' = length . context4l' -- | The inward degree of a 'Context'. indeg' :: Context a b -> Int indeg' = length . context1l' -- | The degree of a 'Context'. 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 -- | 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 -- | 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 -- | 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 ---------------------------------------------------------------------- -- GRAPH EQUALITY ---------------------------------------------------------------------- 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' && glabEdges g == glabEdges g' -- This assumes that nodes aren't repeated (which shouldn't happen for -- sane graph instances). If node IDs are repeated, then the usage of -- slabNodes cannot guarantee stable ordering. -- Newtype wrapper just to test for equality of multiple edges. This -- is needed because without an Ord constraint on `b' it is not -- possible to guarantee a stable ordering on edge labels. newtype GroupEdges b = GEs (LEdge [b]) deriving (Show, Read) instance (Eq b) => Eq (GroupEdges b) where (GEs (v1,w1,bs1)) == (GEs (v2,w2,bs2)) = v1 == v2 && w1 == w2 && eqLists bs1 bs2 eqLists :: (Eq a) => [a] -> [a] -> Bool eqLists xs ys = null (xs \\ ys) && null (ys \\ xs) -- OK to use \\ here as we want each value in xs to cancel a *single* -- value in ys. ---------------------------------------------------------------------- -- UTILITIES ---------------------------------------------------------------------- -- auxiliary functions used in the implementation of the -- derived class members -- (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d -- f .: g = \x y->f (g x y) -- f .: g = (f .) . g -- (.:) f = ((f .) .) -- (.:) = (.) (.) (.) (.:) = (.) . (.) flip2 :: (a,b) -> (b,a) flip2 (x,y) = (y,x) -- projecting on context elements -- context1l :: (Graph gr) => gr a b -> Node -> Adj b context1l = maybe [] context1l' .: mcontext context4l :: (Graph gr) => gr a b -> Node -> Adj b context4l = maybe [] context4l' .: mcontext mcontext :: (Graph gr) => gr a b -> Node -> MContext a b mcontext = fst .: flip match context1l' :: Context a b -> Adj b context1l' (p,v,_,s) = p++filter ((==v).snd) s 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 :: (DynGraph 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 fgl-5.5.4.0/Data/Graph/Inductive/Query.hs0000644000000000000000000000127613142557523016143 0ustar0000000000000000module Data.Graph.Inductive.Query (module Q) where 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 fgl-5.5.4.0/Data/Graph/Inductive/Example.hs0000644000000000000000000001744013142557523016431 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} -- | Example Graphs module Data.Graph.Inductive.Example( -- * Auxiliary Functions genUNodes, genLNodes, labUEdges, noEdges, -- * Small Dynamic Graphs a, b, c, e, loop, ab, abb, dag3, e3, cyc3, g3, g3b, dag4, d1, d3, -- * Small Static Graphs a', b', c', e', loop', ab', abb', dag3', e3', dag4', d1', d3', -- * Functions to Create (Regular) Graphs ucycle, star, ucycleM, starM, -- * More Graphs -- | clr : Cormen\/Leiserson\/Rivest -- | kin : Kingston -- ** Dynamic Versions clr479, clr489, clr486, clr508, clr528, clr595, gr1, kin248, vor, -- ** Static Versions clr479', clr489', clr486', clr508', clr528', kin248', vor' )where import Data.Graph.Inductive.Graph import Data.Graph.Inductive.PatriciaTree import Data.Graph.Inductive.Monad import Data.Graph.Inductive.Monad.IOArray -- | generate list of unlabeled nodes genUNodes :: Int -> [UNode] genUNodes n = zip [1..n] (repeat ()) -- | generate list of labeled nodes genLNodes :: (Enum a) => a -> Int -> [LNode a] genLNodes q i = take i (zip [1..] [q..]) -- | denote unlabeled edges labUEdges :: [Edge] -> [UEdge] labUEdges = map (\(i,j) -> (i,j,())) -- | empty (unlabeled) edge list noEdges :: [UEdge] noEdges = [] a,b,c,e,loop,ab,abb,dag3 :: Gr Char () e3 :: Gr () String cyc3,g3,g3b :: Gr Char String dag4 :: Gr Int () d1,d3 :: Gr Int Int a = ([],1,'a',[]) & empty -- just a node 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) [(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 abb = mkGraph (zip [1..2] "ab") (labUEdges [(2,2)]) -- a and loop on b cyc3 = buildGr -- cycle of three nodes [([("ca",3)],1,'a',[("ab",2)]), ([],2,'b',[("bc",3)]), ([],3,'c',[])] dag3 = mkGraph (zip [1..3] "abc") (labUEdges [(1,3)]) 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)] g3 = ([("left",2),("up",3)],1,'a',[("right",2)]) & ( ([],2,'b',[("down",3)]) & ( ([],3,'c',[]) & empty )) g3b = ([("down",2)], 3,'c',[("up",1)]) & ( ([("right",1)],2,'b',[("left",1)]) & ( ([],1,'a',[]) & empty )) a',b',c',e',loop',ab',abb',dag3' :: IO (SGr Char ()) e3' :: IO (SGr () String) dag4' :: IO (SGr Int ()) d1',d3' :: IO (SGr Int Int) a' = mkGraphM [(1,'a')] noEdges -- just a node 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) [(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") [(1,2,()),(2,1,())] -- cycle of two nodes: a<-->b abb' = mkGraphM (zip [1..2] "ab") (labUEdges [(2,2)]) -- a and loop on b dag3' = mkGraphM (zip [1..3] "abc") (labUEdges [(1,3)]) 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)] 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 n = mkUGraph [1..n] (map (\v->(1,v)) [2..n]) 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 n = mkUGraphM [1..n] (map (\v->(1,v)) [2..n]) clr479,clr489 :: Gr Char () clr486 :: Gr String () clr508,clr528 :: Gr Char Int clr595,gr1 :: Gr Int Int kin248 :: Gr Int () vor :: Gr String Int 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"]) (labUEdges [(1,4),(1,5),(2,5),(4,5),(4,7),(6,7),(6,8),(7,9),(8,9)]) clr489 = mkGraph (genLNodes 'a' 8) (labUEdges [(1,2),(2,3),(2,5),(2,6),(3,4),(3,7),(4,3),(4,8), (5,1),(5,6),(6,7),(7,6),(7,8),(8,8)]) clr508 = mkGraph (genLNodes 'a' 9) [(1,2,4),(1,8,8),(2,3,8),(2,8,11),(3,4,7),(3,6,4),(3,9,2), (4,5,9),(4,6,14),(5,6,10),(6,7,2),(7,8,1),(7,9,6),(8,9,7)] 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]) [(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]) [(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)] kin248 = mkGraph (genLNodes 1 10) (labUEdges [(1,2),(1,4),(1,7),(2,4),(2,5),(3,4),(3,10), (4,5),(4,8),(5,2),(5,3),(6,7),(7,6),(7,8), (8,10),(9,9),(9,10),(10,8),(10,9)]) -- this is the inverse graph shown on the bottom of the page vor = mkGraph (zip [1..8] ["A","B","C","H1","H2","D","E","F"]) [(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)] clr479',clr489' :: IO (SGr Char ()) clr486' :: IO (SGr String ()) clr508',clr528' :: IO (SGr Char Int) kin248' :: IO (SGr Int ()) vor' :: IO (SGr String Int) 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"]) (labUEdges [(1,4),(1,5),(2,5),(4,5),(4,7),(6,7),(6,8),(7,9),(8,9)]) clr489' = mkGraphM (genLNodes 'a' 8) (labUEdges [(1,2),(2,3),(2,5),(2,6),(3,4),(3,7),(4,3),(4,8), (5,1),(5,6),(6,7),(7,6),(7,8),(8,8)]) clr508' = mkGraphM (genLNodes 'a' 9) [(1,2,4),(1,8,8),(2,3,8),(2,8,11),(3,4,7),(3,6,4),(3,9,2), (4,5,9),(4,6,14),(5,6,10),(6,7,2),(7,8,1),(7,9,6),(8,9,7)] clr528' = mkGraphM [(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)] kin248' = mkGraphM (genLNodes 1 10) (labUEdges [(1,2),(1,4),(1,7),(2,4),(2,5),(3,4),(3,10), (4,5),(4,8),(5,2),(5,3),(6,7),(7,6),(7,8), (8,10),(9,9),(9,10),(10,8),(10,9)]) -- this is the inverse graph shown on the bottom of the page vor' = mkGraphM (zip [1..8] ["A","B","C","H1","H2","D","E","F"]) [(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)] fgl-5.5.4.0/Data/Graph/Inductive/Tree.hs0000644000000000000000000001142713142557523015734 0ustar0000000000000000{-# 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.Graph.Inductive.Graph 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 ---------------------------------------------------------------------- newtype Gr a b = Gr (GraphRep a b) #if __GLASGOW_HASKELL__ >= 702 deriving (Generic) #endif type GraphRep a b = Map Node (Context' a b) type Context' a b = (Adj b,a,Adj b) 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) 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 M.empty isEmpty (Gr g) = M.null g match v gr@(Gr g) = maybe (Nothing, gr) (first Just . uncurry (cleanSplit v)) . (\(m,g') -> fmap (flip (,) g') m) $ M.updateLookupWithKey (const (const Nothing)) v g mkGraph vs es = insEdges 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) = 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 #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 :: 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 fgl-5.5.4.0/Data/Graph/Inductive/Basic.hs0000644000000000000000000001073513142557523016057 0ustar0000000000000000-- (c) 1999 - 2002 by Martin Erwig [see file COPYRIGHT] -- | Basic Graph Algorithms module Data.Graph.Inductive.Basic ( -- * Graph Operations grev, undir,unlab, gsel, gfold, -- * Filter Operations efilter,elfilter, -- * Predicates and Classifications hasLoop,isSimple, -- * Tree Operations postorder, postorderF, preorder, preorderF ) where import Data.Graph.Inductive.Graph 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 = gmap (\(p,v,l,s)->(s,v,l,p)) -- | Make the graph undirected, i.e. for every edge from A to B, there -- exists an edge from B to A. undir :: (Eq b,DynGraph gr) => gr a b -> gr a b undir = gmap (\(p,v,l,s)->let ps = nub (p++s) in (ps,v,l,ps)) -- this version of undir considers edge lables and keeps edges with -- different labels, an alternative is the definition below: -- undir = gmap (\(p,v,l,s)-> -- 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 = 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 p = ufold (\c cs->if p c then c:cs else cs) [] -- filter operations -- -- efilter : filter based on edge property -- elfilter : filter based on edge label property -- -- | Filter based on edge property. 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 f = efilter (\(_,_,b)->f b) -- some predicates and classifications -- -- | '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) -- | The inverse of 'hasLoop'. 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 :: (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) -> -- (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 f d b l g = fst (gfoldn f d b l g) -- not finished yet ... -- -- undirBy :: (b -> b -> b) -> Graph a b -> Graph a b -- undirBy = gmap (\(p,v,l,s)->let ps = nub (p++s) in (ps,v,l,ps)) -- | Flatten a 'Tree', returning the elements in post-order. postorder :: Tree a -> [a] postorder (Node v ts) = postorderF ts ++ [v] -- | Flatten multiple 'Tree's in post-order. postorderF :: [Tree a] -> [a] postorderF = concatMap postorder -- | Flatten a 'Tree', returning the elements in pre-order. Equivalent to --'flatten' in 'Data.Tree'. preorder :: Tree a -> [a] preorder = flatten -- | Flatten multiple 'Tree's in pre-order. preorderF :: [Tree a] -> [a] preorderF = concatMap preorder fgl-5.5.4.0/Data/Graph/Inductive/NodeMap.hs0000644000000000000000000002034113142557523016353 0ustar0000000000000000{-# 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, -- ** 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, insMapNodes_, insMapEdges, delMapNodes, delMapEdges, mkMapGraph, -- * Monadic Construction NodeMapM, -- | The following mirror the functional construction functions, but handle passing -- 'NodeMap's and 'Graph's behind the scenes. -- ** Map Construction run, run_, mkNodeM, mkNodesM, mkEdgeM, mkEdgesM, -- ** Graph Construction insMapNodeM, insMapEdgeM, delMapNodeM, delMapEdgeM, insMapNodesM, insMapEdgesM, delMapNodesM, delMapEdgesM ) where import Control.Monad.Trans.State import Data.Graph.Inductive.Graph import Prelude hiding (map) import qualified Prelude as P (map) 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 :: NodeMap a new = NodeMap { map = M.empty, key = 0 } -- LNode = (Node, a) -- | Generate a mapping containing the nodes in the given graph. fromGraph :: (Ord a, Graph g) => g a b -> NodeMap a fromGraph g = let ns = labNodes g 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 } -- | 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 M.lookup a mp of Just i -> ((i, a), m) Nothing -> let m' = NodeMap { map = M.insert a k mp, key = k+1 } in ((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 -- | 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 <- 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 = mapM (mkEdge m) -- | Construct a list of nodes. mkNodes :: (Ord a) => NodeMap a -> [a] -> ([LNode a], NodeMap a) mkNodes = map' mkNode map' :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a) map' _ a [] = ([], a) map' f a (b:bs) = let (c, a') = f a b (cs, a'') = map' f a' bs in (c:cs, a'') -- | Construct a list of nodes and throw away the modified 'NodeMap'. mkNodes_ :: (Ord a) => NodeMap a -> [a] -> [LNode a] mkNodes_ m as = fst $ mkNodes m as insMapNode :: (Ord a, DynGraph g) => NodeMap a -> a -> g a b -> (g a b, NodeMap a, LNode a) insMapNode m a g = let (n, m') = mkNode m a in (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' 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 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 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 insMapNodes :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> (g a b, NodeMap a, [LNode a]) insMapNodes m as g = let (ns, m') = mkNodes m as in (insNodes ns g, m', ns) insMapNodes_ :: (Ord a, DynGraph g) => NodeMap a -> [a] -> g a b -> g a b insMapNodes_ m as g = let (g', _, _) = insMapNodes m as g in g' 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 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 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 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') -- | Graph construction monad; handles passing both the 'NodeMap' and the -- 'Graph'. type NodeMapM a b g r = State (NodeMap a, g a b) r -- | Run a construction; return the value of the computation, the modified -- 'NodeMap', and the modified 'Graph'. run :: (DynGraph g, Ord a) => g a b -> NodeMapM a b g r -> (r, (NodeMap a, g a b)) run g m = runState m (fromGraph g, g) -- | Run a construction and only return the 'Graph'. run_ :: (DynGraph g, Ord a) => g a b -> NodeMapM a b g r -> g a b run_ g m = snd . snd $ run g m {- not used liftN1 :: (Ord a, DynGraph g) => (NodeMap a -> (c, NodeMap a)) -> NodeMapM a b g c liftN1 f = do (m, g) <- get let (r, m') = f m put (m', g) return r liftN1' :: (Ord a, DynGraph g) => (NodeMap a -> c) -> NodeMapM a b g c liftN1' f = do (m, g) <- get return $ f m -} 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' :: (NodeMap a -> c -> d) -> c -> NodeMapM a b g d liftN2' f c = do (m, _) <- get return $ f m c {- not used liftN3 :: (Ord a, DynGraph g) => (NodeMap a -> c -> d -> (e, NodeMap a)) -> c -> d -> NodeMapM a b g e liftN3 f c d = do (m, g) <- get let (r, m') = f m c d put (m', g) return r liftN3' :: (Ord a, DynGraph g) => (NodeMap a -> c -> d -> e) -> c -> d -> NodeMapM a b g e liftN3' f c d = do (m, g) <- get return $ f m c d -} 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' :: (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 put (m', g') return r -- | Monadic node construction. mkNodeM :: (Ord a) => a -> NodeMapM a b g (LNode a) mkNodeM = liftN2 mkNode mkNodesM :: (Ord a) => [a] -> NodeMapM a b g [LNode a] mkNodesM = liftN2 mkNodes mkEdgeM :: (Ord a) => (a, a, b) -> NodeMapM a b g (Maybe (LEdge b)) mkEdgeM = liftN2' mkEdge 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) insMapNodeM = liftM1' insMapNode insMapEdgeM :: (Ord a, DynGraph g) => (a, a, b) -> NodeMapM a b g () insMapEdgeM = liftM1 insMapEdge delMapNodeM :: (Ord a, DynGraph g) => a -> NodeMapM a b g () delMapNodeM = liftM1 delMapNode delMapEdgeM :: (Ord a, DynGraph g) => (a, a) -> NodeMapM a b g () delMapEdgeM = liftM1 delMapEdge insMapNodesM :: (Ord a, DynGraph g) => [a] -> NodeMapM a b g [LNode a] insMapNodesM = liftM1' insMapNodes insMapEdgesM :: (Ord a, DynGraph g) => [(a, a, b)] -> NodeMapM a b g () insMapEdgesM = liftM1 insMapEdges delMapNodesM :: (Ord a, DynGraph g) => [a] -> NodeMapM a b g () delMapNodesM = liftM1 delMapNodes delMapEdgesM :: (Ord a, DynGraph g) => [(a, a)] -> NodeMapM a b g () delMapEdgesM = liftM1 delMapEdges fgl-5.5.4.0/Data/Graph/Inductive/Internal/0000755000000000000000000000000013142557523016250 5ustar0000000000000000fgl-5.5.4.0/Data/Graph/Inductive/Internal/RootPath.hs0000644000000000000000000000247413142557523020353 0ustar0000000000000000-- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT] -- | Inward directed trees as lists of paths. module Data.Graph.Inductive.Internal.RootPath ( -- * Types RTree,LRTree, -- * Operations getPath,getLPath, getDistance, getLPathNodes ) where import Data.Graph.Inductive.Graph type LRTree a = [LPath a] type RTree = [Path] first :: ([a] -> Bool) -> [[a]] -> [a] first p xss = case filter p xss of [] -> [] x:_ -> x -- | 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 getPath :: Node -> RTree -> Path getPath v = reverse . first (\(w:_)->w==v) getLPath :: Node -> LRTree a -> LPath a getLPath v = LP . reverse . 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 fgl-5.5.4.0/Data/Graph/Inductive/Internal/Heap.hs0000644000000000000000000000561313142557523017466 0ustar0000000000000000{-# 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) #if MIN_VERSION_containers (0,4,2) import Control.DeepSeq (NFData (..)) #endif 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 :: Heap a b empty = Empty 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) = merge (unit key val) 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 [Heap a b] -> Heap a b mergeAll [] = Empty mergeAll [h] = h mergeAll (h:h':hs) = merge (merge h h') (mergeAll hs) isEmpty :: Heap a b -> Bool isEmpty Empty = True isEmpty _ = False 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 Empty = Empty deleteMin (Node _ _ hs) = mergeAll hs 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) ---------------------------------------------------------------------- -- APPLICATION FUNCTIONS, EXAMPLES ---------------------------------------------------------------------- build :: (Ord a) => [(a,b)] -> Heap a b build = foldr insert Empty 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)) {- l :: (Num a) => [a] l = [6,9,2,13,6,8,14,9,10,7,5] l' = reverse l h1 = build $ map (\x->(x,x)) l h1' = build $ map (\x->(x,x)) l' s1 = heapsort l s1' = heapsort l' -} fgl-5.5.4.0/Data/Graph/Inductive/Internal/Thread.hs0000644000000000000000000001067113142557523020020 0ustar0000000000000000-- (c) 1999 by Martin Erwig -- | Threading Combinators. module Data.Graph.Inductive.Internal.Thread( -- * Types Split, SplitM, Thread, Collect, -- * Operations threadList', threadList, threadMaybe', threadMaybe, splitPar, splitParM ) where -- import Graph -- import GraphData -- import qualified Diet as D -- import ADT ---------------------------------------------------------------------- -- CLASSES AND TYPES ---------------------------------------------------------------------- {- 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 split x s = (x,D.delete x s) -} {- Make clear different notions: "thread" = data structure + split operation ... = threadable data structure ... = split operation -} ---------------------------------------------------------------------- -- THREAD COMBINATORS ---------------------------------------------------------------------- -- (A) split along a list of indexes and thread data structure -- -- there are different ways to consume the returned elements: {- -- (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 -} -- Mnemonics: -- -- t : thread type -- i : index type -- r : result type -- c : collection type -- type Split t i r = i -> t -> (r,t) type Thread t i r = (t,Split t i r) 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' (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 (f,c) split (i:is) t = (f r c',t'') where (r,t') = split i t (c',t'') = threadList (f,c) split is t' -- (B) thread "maybes", ie, apply f to Just-values and continue -- 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)) -- -> 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 = case mi of Just i -> (Just (f r),t'') where (r,t'') = cont i t' Nothing -> (Nothing,t') where (mi,t') = split j t -- extension: grant f access also to y, the result of split. -- -- threadMaybe :: (a -> b -> c) -> (a -> d -> (b,d)) -> (e -> f -> (Maybe a,d)) -- -> 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 = 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 -- (C) compose splits in parallel (is a kind of generalized zip) -- -- 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')) where (r,t') = split i t (s,u') = split' j u 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 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 -} fgl-5.5.4.0/Data/Graph/Inductive/Internal/Queue.hs0000644000000000000000000000127113142557523017671 0ustar0000000000000000module Data.Graph.Inductive.Internal.Queue( -- * Type Queue(..), -- * Operations mkQueue, queuePut, queuePutList, queueGet, queueEmpty ) where import Data.List (foldl') data Queue a = MkQueue [a] [a] mkQueue :: Queue a mkQueue = MkQueue [] [] queuePut :: a -> Queue a -> Queue a queuePut item (MkQueue ins outs) = MkQueue (item:ins) outs queuePutList :: [a] -> Queue a -> Queue a 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 fgl-5.5.4.0/Data/Graph/Inductive/Monad/0000755000000000000000000000000013142557523015532 5ustar0000000000000000fgl-5.5.4.0/Data/Graph/Inductive/Monad/IOArray.hs0000644000000000000000000000774413142557523017410 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} -- (c) 2002 by Martin Erwig [see file COPYRIGHT] -- | Static IOArray-based Graphs module Data.Graph.Inductive.Monad.IOArray( -- * 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 Data.Array import Data.Array.IO import System.IO.Unsafe ---------------------------------------------------------------------- -- GRAPH REPRESENTATION ---------------------------------------------------------------------- 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) type USGr = SGr () () ---------------------------------------------------------------------- -- CLASS INSTANCES ---------------------------------------------------------------------- -- Show -- showGraph :: (Show a,Show b) => GraphRep a b -> String showGraph (_,a,m) = concatMap showAdj (indices a) where showAdj v | unsafePerformIO (readArray m v) = "" | otherwise = case a!v of 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')}) {- run :: Show (IO a) => IO a -> IO () run x = seq x (print x) -} -- 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 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 -> IO (SGr 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 :: IOArray Node Bool -> Adj b -> IO (Adj b) removeDel m = filterM (\(_,v)->do {b<-readArray m v;return (not b)}) fgl-5.5.4.0/Data/Graph/Inductive/Monad/STArray.hs0000644000000000000000000000766713142557523017433 0ustar0000000000000000{-# 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)}) fgl-5.5.4.0/Data/Graph/Inductive/Query/0000755000000000000000000000000013142557523015601 5ustar0000000000000000fgl-5.5.4.0/Data/Graph/Inductive/Query/Monad.hs0000644000000000000000000001767313142557523017211 0ustar0000000000000000{-# LANGUAGE CPP, MultiParamTypeClasses #-} -- (c) 2002 by Martin Erwig [see file COPYRIGHT] -- | Monadic Graph Algorithms module Data.Graph.Inductive.Query.Monad( -- * Additional Graph Utilities mapFst, mapSnd, (><), orP, -- * Graph Transformer Monad GT(..), apply, apply', applyWith, applyWith', runGT, condMGT', recMGT', condMGT, recMGT, -- * Graph Computations Based on Graph Monads -- ** Monadic Graph Accessing Functions getNode, getContext, getNodes', getNodes, sucGT, sucM, -- ** Derived Graph Recursion Operators graphRec, graphRec', graphUFold, -- * Examples: Graph Algorithms as Instances of Recursion Operators -- ** Instances of graphRec graphNodesM0, graphNodesM, graphNodes, graphFilterM, graphFilter, -- * Example: Monadic DFS Algorithm(s) dfsGT, dfsM, dfsM', dffM, graphDff, graphDff', ) where -- Why all this? -- -- 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 #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative (..)) #endif import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Monad -- some additional (graph) utilities -- mapFst :: (a -> b) -> (a, c) -> (b, c) mapFst f (x,y) = (f x,y) mapSnd :: (a -> b) -> (c, a) -> (c, b) mapSnd f (x,y) = (x,f y) infixr 8 >< (><) :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) (f >< g) (x,y) = (f x,g y) orP :: (a -> Bool) -> (b -> Bool) -> (a,b) -> Bool orP p q (x,y) = p x || q y ---------------------------------------------------------------------- -- "wrapped" state transformer monad == -- monadic graph transformer monad ---------------------------------------------------------------------- newtype GT m g a = MGT (m g -> m (a,g)) apply :: GT m g a -> m g -> m (a,g) apply (MGT f) = f 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 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' h gt = applyWith h gt . return 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) => Applicative (GT m g) where pure = return (<*>) = ap instance (Monad m) => Monad (GT m g) where return x = MGT (\mg->do {g<-mg; return (x,g)}) f >>= h = MGT (\mg->do {(x,g)<-apply f mg; apply' (h x) g}) condMGT' :: (Monad m) => (s -> Bool) -> GT m s a -> GT m s a -> GT m s a condMGT' 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) (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 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) (do {x<-mg;y<-recMGT p mg f u;return (f x y)}) ---------------------------------------------------------------------- -- graph computations based on state monads/graph monads ---------------------------------------------------------------------- -- some monadic graph accessing functions -- 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 = 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 []) nodeGetter getNodes :: (GraphM m gr) => GT m (gr a b) [Node] getNodes = condMGT isEmptyM (return []) nodeGetter 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 v = runGT (sucGT v) ---------------------------------------------------------------------- -- 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) -- (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 -> (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 -> (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 = graphRec getContext ---------------------------------------------------------------------- -- Examples: graph algorithms as instances of recursion operators ---------------------------------------------------------------------- -- instances of graphRec -- graphNodesM0 :: (GraphM m gr) => GT m (gr a b) [Node] graphNodesM0 = graphRec getNode (:) [] 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 = runGT graphNodesM 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 p = runGT (graphFilterM p) ---------------------------------------------------------------------- -- Example: monadic dfs algorithm(s) ---------------------------------------------------------------------- -- | Monadic graph algorithms are defined in two steps: -- -- (1) define the (possibly parameterized) graph transformer (e.g., dfsGT) -- (2) run the graph transformer (applied to arguments) (e.g., dfsM) -- dfsGT :: (GraphM m gr) => [Node] -> GT m (gr a b) [Node] dfsGT [] = return [] dfsGT (v:vs) = MGT (\mg-> do (mc,g') <- matchM v mg case mc of Just (_,_,_,s) -> applyWith' (v:) (dfsGT (map snd s++vs)) g' Nothing -> apply' (dfsGT vs) g' ) -- | depth-first search yielding number of nodes 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' 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 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 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) ) 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' mg = do {vs <- nodesM mg; runGT (dffM vs) mg} fgl-5.5.4.0/Data/Graph/Inductive/Query/TransClos.hs0000644000000000000000000000244413142557523020051 0ustar0000000000000000module Data.Graph.Inductive.Query.TransClos( trc, rc, tc ) where import Data.Graph.Inductive.Graph 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} -} 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 transitive, reflexive 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 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 transitive closure is the graph: G* = (V,Er union E) where Er = {(i,i): i in V} -} rc :: (DynGraph gr) => gr a b -> gr a () rc g = newEdges `insEdges` insNodes ln empty where ln = labNodes g newEdges = [ (u, u, ()) | (u, _) <- ln ] fgl-5.5.4.0/Data/Graph/Inductive/Query/MST.hs0000644000000000000000000000247013142557523016603 0ustar0000000000000000-- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT] -- | Minimum-Spanning-Tree Algorithms module Data.Graph.Inductive.Query.MST ( msTreeAt,msTree, -- * Path in MST msPath, -- * Types used LRTree ) where import Data.Graph.Inductive.Graph import qualified Data.Graph.Inductive.Internal.Heap as H import Data.Graph.Inductive.Internal.RootPath 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 msTreeAt :: (Graph gr,Real b) => Node -> gr a b -> LRTree b 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 :: LRTree b -> Node -> Node -> Path msPath t a b = joinPaths (getLPathNodes a t) (getLPathNodes b t) 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) fgl-5.5.4.0/Data/Graph/Inductive/Query/MaxFlow.hs0000644000000000000000000001334713142557523017522 0ustar0000000000000000-- | 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: -- -- @ -- 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 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. module Data.Graph.Inductive.Query.MaxFlow( getRevEdges, augmentGraph, updAdjList, updateFlow, mfmg, mf, maxFlowgraph, maxFlow ) where import Data.List import Data.Graph.Inductive.Basic import Data.Graph.Inductive.Graph --import Data.Graph.Inductive.Tree import Data.Graph.Inductive.Query.BFS -- | -- @ -- i 0 -- For each edge a--->b this function returns edge b--->a . -- i -- Edges a\<--->b are ignored -- j -- @ getRevEdges :: (Num b) => [Edge] -> [LEdge b] getRevEdges [] = [] getRevEdges ((u,v):es) | (v,u) `notElem` es = (v,u,0):getRevEdges es | otherwise = getRevEdges (delete (v,u) es) -- | -- @ -- i 0 -- For each edge a--->b insert into graph the edge a\<---b . Then change the -- 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) => 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) => Adj (b,b,b) -> Node -> b -> Bool -> Adj (b,b,b) updAdjList s v cf fwd = rs ++ ((x,y+cf',z-cf'),w) : rs' where (rs, ((x,y,z),w):rs') = break ((v==) . snd) s 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' (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 -- | 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 = 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 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 = 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 -- that for a given flow graph the maximum flow is not unique. -- (gr595 is defined in GraphData.hs) ------------------------------------------------------------------------------ fgl-5.5.4.0/Data/Graph/Inductive/Query/Dominators.hs0000644000000000000000000001214313142557523020255 0ustar0000000000000000-- Find Dominators of a graph. -- -- Author: Bertram Felgenhauer -- -- Implementation based on -- Keith D. Cooper, Timothy J. Harvey, Ken Kennedy, -- "A Simple, Fast Dominance Algorithm", -- (http://citeseer.ist.psu.edu/cooper01simple.html) module Data.Graph.Inductive.Query.Dominators ( dom, iDom ) where 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.Tree (Tree (..)) import qualified Data.Tree as T {-# ANN iDom "HLint: ignore Use ***" #-} -- | return immediate dominators for each node of a graph, given a root iDom :: (Graph gr) => gr a b -> Node -> [(Node,Node)] iDom g root = let (result, toNode, _) = idomWork g root in map (\(a, b) -> (toNode ! a, toNode ! b)) (assocs result) -- | return the set of dominators of the nodes of a graph, given a root dom :: (Graph gr) => gr a b -> Node -> [(Node,[Node])] dom g root = let (iD, toNode, fromNode) = idomWork g root dom' = getDom toNode iD nodes' = nodes g rest = I.keys (I.filter (-1 ==) fromNode) in [(toNode ! i, dom' ! i) | i <- range (bounds dom')] ++ [(n, nodes') | n <- rest] -- internal node type type Node' = Int -- array containing the immediate dominator of each node, or an approximation -- thereof. the dominance set of a node can be found by taking the union of -- {node} and the dominance set of its immediate dominator. type IDom = Array Node' Node' -- array containing the list of predecessors of each node type Preds = Array Node' [Node'] -- arrays for translating internal nodes back to graph nodes and back 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 iD0 = array (1, s-1) (tail $ treeEdges (-1) ntree) -- fromNode translates graph nodes to relabeled (internal) nodes fromNode = I.unionWith const (I.fromList (zip (T.flatten tree) (T.flatten ntree))) (I.fromList (zip (nodes g) (repeat (-1)))) -- toNode translates internal nodes to graph nodes toNode = array (0, s-1) (zip (T.flatten ntree) (T.flatten tree)) preds = array (1, s-1) [(i, filter (/= -1) (map (fromNode I.!) (pre g (toNode ! i)))) | i <- [1..s-1]] -- iteratively improve the approximation to find iDom. iD = fixEq (refineIDom preds) iD0 in if null trees then error "Dominators.idomWork: root not in graph" else (iD, toNode, fromNode) -- 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 iD = fmap (foldl1 (intersect iD)) preds -- find the intersection of the two given dominance sets. intersect :: IDom -> Node' -> Node' -> Node' intersect iD a b = case a `compare` b of LT -> intersect iD a (iD ! b) EQ -> a 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 iD = let res = array (0, snd (bounds iD)) ((0, [toNode ! 0]) : [(i, toNode ! i : res ! (iD ! i)) | i <- range (bounds iD)]) in res -- relabel tree, labeling vertices with consecutive numbers in depth first order numberTree :: Node' -> Tree a -> (Node', Tree Node') numberTree n (Node _ ts) = let (n', ts') = numberForest (n+1) ts in (n', Node n ts') -- same as numberTree, for forests. numberForest :: Node' -> [Tree a] -> (Node', [Tree Node']) numberForest n [] = (n, []) numberForest n (t:ts) = let (n', t') = numberTree n t (n'', ts') = numberForest n' ts in (n'', t':ts') -- return the edges of the tree, with an added dummy root node. treeEdges :: a -> Tree a -> [(a,a)] 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 f v | v' == v = v | otherwise = fixEq f v' where v' = f v {- :m +Data.Graph.Inductive let g0 = mkGraph [(i,()) | i <- [0..4]] [(a,b,()) | (a,b) <- [(0,1),(1,2),(0,3),(3,2),(4,0)]] :: Gr () () let g1 = mkGraph [(i,()) | i <- [0..4]] [(a,b,()) | (a,b) <- [(0,1),(1,2),(2,3),(1,3),(3,4)]] :: Gr () () let g2,g3,g4 :: Int -> Gr () (); g2 n = mkGraph [(i,()) | i <- [0..n-1]] ([(a,a+1,()) | a <- [0..n-2]] ++ [(a,a+2,()) | a <- [0..n-3]]); g3 n =mkGraph [(i,()) | i <- [0..n-1]] ([(a,a+2,()) | a <- [0..n-3]] ++ [(a,a+1,()) | a <- [0..n-2]]); g4 n =mkGraph [(i,()) | i <- [0..n-1]] ([(a+2,a,()) | a <- [0..n-3]] ++ [(a+1,a,()) | a <- [0..n-2]]) :m -Data.Graph.Inductive -} fgl-5.5.4.0/Data/Graph/Inductive/Query/Indep.hs0000644000000000000000000000171613142557523017201 0ustar0000000000000000-- (c) 2000 - 2002 by Martin Erwig [see file COPYRIGHT] -- | Maximum Independent Node Sets module Data.Graph.Inductive.Query.Indep ( indep , indepSize ) where import Data.Graph.Inductive.Graph import Control.Arrow ((***)) import Data.Function (on) import Data.List (maximumBy) -- ----------------------------------------------------------------------------- -- | Calculate the maximum independent node set of the specified -- graph. indep :: (DynGraph gr) => gr a b -> [Node] indep = fst . indepSize -- | The maximum independent node set along with its size. indepSize :: (DynGraph gr) => gr a b -> ([Node], Int) indepSize g | isEmpty g = ([], 0) | l1 > l2 = il1 | otherwise = il2 where vs = nodes g v = snd . maximumBy (compare `on` fst) . map ((,) =<< deg g) $ vs (Just c,g') = match v g il1@(_,l1) = indepSize g' il2@(_,l2) = ((v:) *** (+1)) $ indepSize (delNodes (neighbors' c) g') fgl-5.5.4.0/Data/Graph/Inductive/Query/SP.hs0000644000000000000000000000445213142557523016464 0ustar0000000000000000-- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT] -- | Shortest path algorithms module Data.Graph.Inductive.Query.SP( spTree , sp , spLength , dijkstra , LRTree , H.Heap ) where import qualified Data.Graph.Inductive.Internal.Heap as H 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 d (LP p) (_,_,_,s) = map (\(l,v)->H.unit (l+d) (LP ((v,l+d):p))) s -- | 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 -- | 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)])) -- | Length of the shortest path between two nodes, if any. -- -- Returns 'Nothing' if there is no path, and @'Just' @ -- 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 -- | Shortest path between two nodes, if any. -- -- Returns 'Nothing' if the destination is not reachable from the -- start node, and @'Just' @ 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 fgl-5.5.4.0/Data/Graph/Inductive/Query/ArtPoint.hs0000644000000000000000000001402713142557523017701 0ustar0000000000000000module Data.Graph.Inductive.Query.ArtPoint( ap ) where import Data.Graph.Inductive.Graph ------------------------------------------------------------------------------ -- Tree for storing the DFS numbers and back edges for each node in the graph. -- Each node in this tree is of the form (v,n,b) where v is the vertex number, -- n is its DFS number and b is the list of nodes (and their DFS numbers) that -- lead to back back edges for that vertex v. ------------------------------------------------------------------------------ data DFSTree a = B (a,a,[(a,a)]) [DFSTree a] deriving (Eq, Show, Read) ------------------------------------------------------------------------------ -- Tree for storing the DFS and low numbers for each node in the graph. -- Each node in this tree is of the form (v,n,l) where v is the vertex number, -- n is its DFS number and l is its low number. ------------------------------------------------------------------------------ data LOWTree a = Brc (a,a,a) [LOWTree a] deriving (Eq, Show, Read) ------------------------------------------------------------------------------ -- Finds the back edges for a given node. ------------------------------------------------------------------------------ getBackEdges :: Node -> [[(Node,Int)]] -> [(Node,Int)] getBackEdges _ [] = [] getBackEdges v ls = map head (filter (elem (v,0)) (tail ls)) ------------------------------------------------------------------------------ -- 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)]] -> gr a b -> ([DFSTree Int],gr a b,Int) dfsTree n _ [] _ g = ([],g,n) dfsTree n _ _ _ g | isEmpty g = ([],g,n) dfsTree n u (v:vs) ls g = case match v g of (Nothing, g1) -> dfsTree n u vs ls g1 (Just c , g1) -> (B (v,n+1,bck) ts:ts', g3, k) where bck = getBackEdges v ls (ts, g2,m) = dfsTree (n+1) v sc ls' g1 (ts',g3,k) = dfsTree m v vs ls g2 ls' = ((v,n+1):sc'):ls sc' = map (\x->(x,0)) sc sc = suc' c ------------------------------------------------------------------------------ -- Finds the minimum between a dfs number and a list of back edges' dfs -- numbers. ------------------------------------------------------------------------------ minbckEdge :: Int -> [(Node,Int)] -> Int minbckEdge n [] = n minbckEdge n bs = min n (minimum (map snd bs)) ------------------------------------------------------------------------------ -- Returns the low number for a node in a subtree. ------------------------------------------------------------------------------ getLow :: LOWTree Int -> Int getLow (Brc (_,_,l) _) = l ------------------------------------------------------------------------------ -- Builds a low tree from a DFS tree. Each element (v,n,low) in the tree -- 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,bcks) trs) = Brc (v,n,lowv) ts where lowv = min (minbckEdge n bcks) lowChild lowChild = minimum (map getLow ts) ts = map lowTree trs ------------------------------------------------------------------------------ -- 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 g v = lowTree (head dfsf) where (dfsf, _, _) = dfsTree 0 0 [v] [] g ------------------------------------------------------------------------------ -- Tests if a node in a subtree is an articulation point. 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). The root node is an articulation point -- iff it has two or more children. ------------------------------------------------------------------------------ isap :: LOWTree Int -> Bool isap (Brc (_,_,_) []) = False isap (Brc (_,1,_) ts) = length ts > 1 isap (Brc (_,n,_) ts) = not (null ch) where ch = filter ( >=n) (map getLow ts) ------------------------------------------------------------------------------ -- Finds the articulation points by traversing the low tree. ------------------------------------------------------------------------------ arp :: LOWTree Int -> [Node] arp (Brc (v,1,_) ts) | length ts > 1 = v:concatMap arp ts | otherwise = concatMap arp ts arp (Brc (v,n,l) ts) | isap (Brc (v,n,l) ts) = v:concatMap arp ts | otherwise = concatMap arp ts ------------------------------------------------------------------------------ -- Finds the articulation points of a graph starting at a given node. ------------------------------------------------------------------------------ artpoints :: (Graph gr) => gr a b -> Node -> [Node] artpoints g v = arp (getLowTree g v) {-| Finds the articulation points for a connected undirected graph, by using the low numbers criteria: a) The root node is an articulation point iff it has two or more children. 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 g = artpoints g v where ((_,v,_,_),_) = matchAny g fgl-5.5.4.0/Data/Graph/Inductive/Query/BCC.hs0000644000000000000000000000515413142557523016531 0ustar0000000000000000module Data.Graph.Inductive.Query.BCC( bcc ) where import Data.Graph.Inductive.Graph 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 = 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 = zipWith (&) lc gs where lc = map (\e->(e,v,l,e)) lc' lc'= map (\g->[ e | e <- s, gelem (snd e) g]) gs ------------------------------------------------------------------------------ -- 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 _ [] = 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') (Just c, g') -> ((Just c, g'), gs) ------------------------------------------------------------------------------ -- Given a graph g and its articulation points, this function disconnects g -- 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 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 {-| 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 g = splitGraphs [g] (ap g) fgl-5.5.4.0/Data/Graph/Inductive/Query/BFS.hs0000644000000000000000000001006713142557523016553 0ustar0000000000000000-- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT] -- | Breadth-First Search Algorithms module Data.Graph.Inductive.Query.BFS( -- * BFS Node List bfs, bfsn, bfsWith, bfsnWith, -- * Node List With Depth Info level, leveln, -- * BFS Edges bfe, bfen, -- * BFS Tree bft, lbft, RTree, -- * Shortest Path (Number of Edges) esp, lesp ) where import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Internal.Queue import Data.Graph.Inductive.Internal.RootPath -- bfs (node list ordered by distance) -- 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 (Just c, g') -> f c:bfsnInternal f (queuePutList (suc' c) q') g' (Nothing, g') -> bfsnInternal f q' g' where (v,q') = queueGet q 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 = bfsnWith node' 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 = bfsWith node' -- level (extension of bfs giving the depth of each node) -- 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 [] _ = [] 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' -- bfe (breadth first edges) -- remembers predecessor information -- bfenInternal :: (Graph gr) => Queue Edge -> gr a b -> [Edge] bfenInternal q g | queueEmpty q || isEmpty g = [] | 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 = bfenInternal (queuePutList vs mkQueue) bfe :: (Graph gr) => Node -> gr a b -> [Edge] bfe v = bfen [(v,v)] outU :: Context a b -> [Edge] outU c = map toEdge (out' c) -- bft (breadth first search tree) -- here: with inward directed trees -- -- 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 -- here: with root path trees -- bft :: (Graph gr) => Node -> gr a b -> RTree bft v = bf (queuePut [v] mkQueue) 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 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. -- 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 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 lesp :: (Graph gr) => Node -> Node -> gr a b -> LPath b lesp s t = getLPath t . lbft s fgl-5.5.4.0/Data/Graph/Inductive/Query/MaxFlow2.hs0000644000000000000000000002227013142557523017577 0ustar0000000000000000-- | Alternative Maximum Flow module Data.Graph.Inductive.Query.MaxFlow2( Network, ekSimple, ekFused, ekList, ) where -- ekSimple, ekFused, ekList) where import Data.Maybe import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Internal.Queue import Data.Graph.Inductive.PatriciaTree import Data.Graph.Inductive.Query.BFS (bft) import Data.Set (Set) import qualified Data.Set as S ------------------------------------------------------------------------------ -- Data types -- Network data type type Network = Gr () (Double, Double) -- Data type for direction in which an edge is traversed data Direction = Forward | Backward deriving (Eq, Ord, Show, Read) -- Data type for edge with direction of traversal type DirEdge b = (Node, Node, b, Direction) type DirPath=[(Node, Direction)] type DirRTree=[DirPath] pathFromDirPath :: DirPath -> [Node] pathFromDirPath = map fst ------------------------------------------------------------------------------ -- Example networks -- Example number 1 -- This network has a maximum flow of 2000 {- exampleNetwork1 :: Network exampleNetwork1=mkGraph [ (1,()), (2,()), (3,()), (4,()) ] [ (1,2,(1000,0)), (1,3,(1000,0)), (2,3,(1,0)), (2,4,(1000,0)), (3,4,(1000,0)) ] -- Example number 2 -- 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=mkGraph [ (1,()), (2,()), (3,()), (4,()), (5,()), (6,()) ] [ (1, 2, (16, 0)), (1, 3, (13, 0)), (2, 3, (10, 0)), (3, 2, (4, 0)), (2, 4, (12, 0)), (3, 5, (14, 0)), (4, 3, (9, 0)), (5, 4, (7, 0)), (4, 6, (20, 0)), (5, 6, (4, 0)) ] -} ------------------------------------------------------------------------------ -- Implementation of Edmonds-Karp algorithm -- 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 where tree = bftForEK s g -- Breadth First Search wrapper function bftForEK :: Node -> Network -> DirRTree bftForEK v = bfForEK (queuePut [(v,Forward)] mkQueue) -- 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 (Nothing, g') -> bfForEK q1 g' (Just (preAdj, _, _, sucAdj), g') -> p:bfForEK q2 g' where -- Insert successor nodes (with path to root) into queue q2 = queuePutList suc1 $ queuePutList suc2 q1 -- Traverse edges in reverse if flow positive suc1 = [ (preNode, Backward):p | ((_, f), preNode) <- preAdj, f>0] -- 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 -- path removed. 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 (uncurry (>)) extractPathFused g ((u,_):rest@((v,Backward):_)) = ((v, u, l, Backward):tailedges, newerg) where (tailedges, newerg) = extractPathFused newg rest Just (l, newg) = extractEdge g v u (\(_,f)->(f>0)) ekFusedStep :: EKStepFunc ekFusedStep g s t = case maybePath of Just _ -> Just (insEdges (integrateDelta es delta) newg, delta) Nothing -> Nothing where maybePath = augPathFused g s t (es, newg) = extractPathFused g (fromJust maybePath) delta = minimum $ getPathDeltas es ekFused :: Network -> Node -> Node -> (Network, Double) ekFused = ekWith ekFusedStep -- ENDEXTRACT ----------------------------------------------------------------------------- -- Alternative implementation: Use an explicit residual graph -- EXTRACT fglEdmondsSimple.txt residualGraph :: Network -> Gr () Double 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 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 -- path removed. extractPath :: Network -> Path -> ([DirEdge (Double,Double)], Network) extractPath g [] = ([], g) extractPath g [_] = ([], g) extractPath g (u:v:ws) = case fwdExtract of Just (l, newg) -> ((u, v, l, Forward):tailedges, newerg) where (tailedges, newerg) = extractPath newg (v:ws) Nothing -> case revExtract of 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 (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') -- 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) 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 integrateDelta :: [DirEdge (Double,Double)] -> Double -> [LEdge (Double, Double)] integrateDelta [] _ = [] integrateDelta (e:es) delta = case e of (u, v, (c, f), Forward) -> (u, v, (c, f+delta)) : integrateDelta es delta (u, v, (c, f), 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) Nothing -> Nothing where maybePath = augPath g s t (es, newg) = extractPath g (fromJust maybePath) delta = minimum $ getPathDeltas es 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 Nothing -> (g, 0) ekSimple :: Network -> Node -> Node -> (Network, Double) ekSimple = ekWith ekSimpleStep -- ENDEXTRACT ----------------------------------------------------------------------------- -- Alternative implementation: Process list of edges to extract path instead -- of operating on graph structure 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) && S.member (u,v) set = let (pathrest, notrest)=extractPathList es (S.delete (u,v) set) in ((u,v,l,Forward):pathrest, notrest) | (f>0) && S.member (v,u) set = 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 (pathrest, edge:notrest) ekStepList :: EKStepFunc ekStepList g s t = case maybePath of Just _ -> Just (mkGraph (labNodes g) newEdges, delta) Nothing -> Nothing where newEdges = integrateDelta es delta ++ otheredges maybePath = augPathFused g s t (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 fgl-5.5.4.0/Data/Graph/Inductive/Query/GVD.hs0000644000000000000000000000522313142557523016557 0ustar0000000000000000-- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT] -- | Graph Voronoi Diagram -- -- These functions can be used to create a /shortest path forest/ -- where the roots are specified. module Data.Graph.Inductive.Query.GVD ( Voronoi,LRTree, gvdIn,gvdOut, voronoiSet,nearestNode,nearestDist,nearestPath, -- vd,nn,ns, -- vdO,nnO,nsO ) where import Data.List (nub) import Data.Maybe (listToMaybe) import qualified Data.Graph.Inductive.Internal.Heap as H import Data.Graph.Inductive.Basic import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Internal.RootPath import Data.Graph.Inductive.Query.SP (dijkstra) -- | Representation of a shortest path forest. type Voronoi a = LRTree a -- | Produce a shortest path forest (the roots of which are those -- nodes specified) from nodes in the graph /to/ one of the root -- nodes (if possible). gvdIn :: (DynGraph gr, Real b) => [Node] -> gr a b -> Voronoi b gvdIn vs g = gvdOut vs (grev g) -- | Produce a shortest path forest (the roots of which are those -- nodes specified) from nodes in the graph /from/ one of the root -- nodes (if possible). gvdOut :: (Graph gr, Real b) => [Node] -> gr a b -> Voronoi b gvdOut vs = dijkstra (H.build (zip (repeat 0) (map (\v->LP [(v,0)]) vs))) -- | 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) -- | 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) -- | 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 -- | 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 -- | 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 -- vdO = gvdOut [4,5] vor -- nn = map (flip nearestNode vd) [1..8] -- nnO = map (flip nearestNode vdO) [1..8] -- ns = map (flip voronoiSet vd) [1..8] -- nsO = map (flip voronoiSet vdO) [1..8] fgl-5.5.4.0/Data/Graph/Inductive/Query/DFS.hs0000644000000000000000000001707113142557523016557 0ustar0000000000000000-- (c) 2000 - 2005 by Martin Erwig [see file COPYRIGHT] -- | 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 ( CFun, -- * Standard dfs, dfs', dff, dff', dfsWith, dfsWith', dffWith, dffWith', xdfsWith, xdfWith, xdffWith, -- * Undirected udfs, udfs', udff, udff', udffWith, udffWith', -- * Reversed rdff, rdff', rdfs, rdfs', rdffWith, rdffWith', -- * Applications of depth first search/forest topsort, topsort', scc, reachable, -- * Applications of undirected depth first search/forest components, noComponents, isConnected, condensation ) where import Data.Graph.Inductive.Basic import Data.Graph.Inductive.Graph import Data.Tree import qualified Data.Map as Map import Control.Monad (liftM2) -- | 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 type CFun a b c = Context 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' -- | 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' f = fixNodes (dfsWith f) dfs' :: (Graph gr) => gr a b -> [Node] dfs' = dfsWith' 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' = fixNodes udfs -- | 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' = fixNodes rdfs -- | 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) where (ts,g2) = xdfWith d f (d c) g1 (ts',g3) = xdfWith d f vs g2 -- | 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) -- | 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' f = fixNodes (dffWith f) dff' :: (Graph gr) => gr a b -> [Tree Node] dff' = dffWith' node' -- | Undirected depth-first forest, obtained by following edges regardless -- of their direction. udff :: (Graph gr) => [Node] -> gr a b -> [Tree Node] udff = udffWith node' udffWith :: (Graph gr) => CFun a b c -> [Node] -> gr a b -> [Tree c] udffWith = xdffWith neighbors' udffWith' :: (Graph gr) => CFun a b c -> gr a b -> [Tree c] udffWith' f = fixNodes (udffWith f) 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 ---------------------------------------------------------------------- -- | Collection of connected components components :: (Graph gr) => gr a b -> [[Node]] components = map preorder . udff' -- | Number of connected components noComponents :: (Graph gr) => gr a b -> Int noComponents = length . components -- | 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 -- | , -- 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', returning only the labels of the nodes. topsort' :: (Graph gr) => gr a b -> [a] topsort' = reverse . postorderF . dffWith' lab' -- | Collection of strongly connected components scc :: (Graph gr) => gr a b -> [[Node]] scc g = map preorder (rdff (topsort g) g) -- | Collection of nodes reachable from a starting point. reachable :: (Graph gr) => Node -> gr a b -> [Node] reachable v g = preorderF (dff [v] g) -- | The condensation of the given graph, i.e., the graph of its -- strongly connected components. condensation :: Graph gr => gr a b -> gr [Node] () condensation gr = mkGraph vs es where sccs = scc gr vs = zip [1..] sccs vMap = Map.fromList $ map swap vs swap = uncurry $ flip (,) getN = (vMap Map.!) es = [ (getN c1, getN c2, ()) | c1 <- sccs, c2 <- sccs , (c1 /= c2) && any (hasEdge gr) (liftM2 (,) c1 c2) ]