fgl-5.4.2.4/0000755000000000000000000000000011622121474010622 5ustar0000000000000000fgl-5.4.2.4/LICENSE0000644000000000000000000000277611622121474011643 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.4.2.4/Setup.hs0000644000000000000000000000012711622121474012256 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain fgl-5.4.2.4/fgl.cabal0000644000000000000000000000353211622121474012361 0ustar0000000000000000name: fgl version: 5.4.2.4 license: BSD3 license-file: LICENSE author: Martin Erwig, Ivan Lazar Miljenovic maintainer: Ivan.Miljenovic@gmail.com, tomberek@gmail.com homepage: http://web.engr.oregonstate.edu/~erwig/fgl/haskell category: Data Structures, Graphs synopsis: Martin Erwig's Functional Graph Library cabal-version: >= 1.6 build-type: Simple source-repository head type: darcs location: http://code.haskell.org/FGL/fgl-5 library { exposed-modules: Data.Graph.Inductive.Internal.FiniteMap, Data.Graph.Inductive.Internal.Heap, Data.Graph.Inductive.Internal.Queue, Data.Graph.Inductive.Internal.RootPath, Data.Graph.Inductive.Internal.Thread, Data.Graph.Inductive.Basic, Data.Graph.Inductive.Example, Data.Graph.Inductive.Graph, Data.Graph.Inductive.Graphviz, Data.Graph.Inductive.Monad, Data.Graph.Inductive.NodeMap, Data.Graph.Inductive.PatriciaTree, Data.Graph.Inductive.Query, Data.Graph.Inductive.Tree, Data.Graph.Inductive.Monad.IOArray, Data.Graph.Inductive.Query.ArtPoint, Data.Graph.Inductive.Query.BCC, Data.Graph.Inductive.Query.BFS, Data.Graph.Inductive.Query.DFS, Data.Graph.Inductive.Query.Dominators, Data.Graph.Inductive.Query.GVD, Data.Graph.Inductive.Query.Indep, Data.Graph.Inductive.Query.MST, Data.Graph.Inductive.Query.MaxFlow, Data.Graph.Inductive.Query.MaxFlow2, Data.Graph.Inductive.Query.Monad, Data.Graph.Inductive.Query.SP, Data.Graph.Inductive.Query.TransClos, Data.Graph.Inductive build-depends: base < 5, mtl, containers, array extensions: MultiParamTypeClasses, OverlappingInstances, FlexibleInstances, ScopedTypeVariables } fgl-5.4.2.4/Data/0000755000000000000000000000000011622121474011473 5ustar0000000000000000fgl-5.4.2.4/Data/Graph/0000755000000000000000000000000011622121474012534 5ustar0000000000000000fgl-5.4.2.4/Data/Graph/Inductive.hs0000644000000000000000000000204511622121474015023 0ustar0000000000000000------------------------------------------------------------------------------ -- -- Inductive.hs -- Functional Graph Library -- -- (c) 1999-2007 by Martin Erwig [see file COPYRIGHT] -- ------------------------------------------------------------------------------ module Data.Graph.Inductive( module Data.Graph.Inductive.Graph, module Data.Graph.Inductive.Tree, module Data.Graph.Inductive.Basic, module Data.Graph.Inductive.Monad, module Data.Graph.Inductive.Monad.IOArray, module Data.Graph.Inductive.Query, module Data.Graph.Inductive.Graphviz, module Data.Graph.Inductive.NodeMap, -- * Version Information version ) where import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Tree import Data.Graph.Inductive.Basic import Data.Graph.Inductive.Monad import Data.Graph.Inductive.Monad.IOArray import Data.Graph.Inductive.Query import Data.Graph.Inductive.Graphviz import Data.Graph.Inductive.NodeMap -- | Version info version :: IO () version = putStrLn "\nFGL - Functional Graph Library, April 2007" fgl-5.4.2.4/Data/Graph/Inductive/0000755000000000000000000000000011622121474014466 5ustar0000000000000000fgl-5.4.2.4/Data/Graph/Inductive/Graphviz.hs0000644000000000000000000000403511622121474016616 0ustar0000000000000000-- | Simple graphviz output. module Data.Graph.Inductive.Graphviz( Orient(..), graphviz, graphviz' ) where import Data.Graph.Inductive.Graph data Orient = Portrait | Landscape deriving (Eq, Show) o2s :: Orient -> String o2s Portrait = "\trotate = \"0\"\n" o2s Landscape = "\trotate = \"90\"\n" -- | Formats a graph for use in graphviz. graphviz :: (Graph g, Show a, Show b) => g a b -- ^ The graph to format -> String -- ^ The title of the graph -> (Double, Double) -- ^ The size -- of the page -> (Int, Int) -- ^ The width and -- height of the page -- grid -> Orient -- ^ The orientation of -- the graph. -> String i2d :: Int -> Double i2d = fromInteger . toInteger graphviz g t (w, h) p@(pw', ph') o = let n = labNodes g e = labEdges g ns = concatMap sn n es = concatMap se e sz w' h' = if o == Portrait then show w'++","++show h' else show h'++","++show w' ps = show w++","++show h (pw, ph) = if o == Portrait then p else (ph', pw') --gs = show ((w*(i2d pw))-m)++","++show ((h*(i2d ph))-m) gs = sz (w*(i2d pw)) (h*(i2d ph)) in "digraph "++t++" {\n" ++"\tmargin = \"0\"\n" ++"\tpage = \""++ps++"\"\n" ++"\tsize = \""++gs++"\"\n" ++o2s o ++"\tratio = \"fill\"\n" ++ns ++es ++"}" where sn (n, a) | sa == "" = "" | otherwise = '\t':(show n ++ sa ++ "\n") where sa = sl a se (n1, n2, b) = '\t':(show n1 ++ " -> " ++ show n2 ++ sl b ++ "\n") -- | Format a graph for graphviz with reasonable defaults: title of \"fgl\", -- 8.5x11 pages, one page, landscape orientation graphviz' :: (Graph g, Show a, Show b) => g a b -> String graphviz' g = graphviz g "fgl" (8.5,11.0) (1,1) Landscape sq :: String -> String sq s@[c] = s sq ('"':s) | last s == '"' = init s | otherwise = s sq ('\'':s) | last s == '\'' = init s | otherwise = s sq s = s sl :: (Show a) => a -> String sl a = let l = sq (show a) in if (l /= "()") then (" [label = \""++l++"\"]") else "" fgl-5.4.2.4/Data/Graph/Inductive/Graph.hs0000644000000000000000000003713311622121474016072 0ustar0000000000000000-- (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 -- ** Graph Folds and Maps ufold,gmap,nmap,emap, -- ** Graph Projection nodes,edges,newNodes,gelem, -- ** Graph Construction and Destruction insNode,insEdge,delNode,delEdge,delLEdge, insNodes,insEdges,delNodes,delEdges, buildGr,mkUGraph, -- ** Graph Inspection context,lab,neighbors, suc,pre,lsuc,lpre, out,inn,outdeg,indeg,deg, equal, -- ** Context Inspection node',lab',labNode',neighbors', suc',pre',lpre',lsuc', out',inn',outdeg',indeg',deg', ) where import Data.List (sortBy) {- Signatures: -- basic operations empty :: Graph gr => gr a b isEmpty :: Graph gr => gr a b -> Bool match :: Graph gr => Node -> gr a b -> Decomp gr a b mkGraph :: Graph gr => [LNode a] -> [LEdge b] -> gr a b (&) :: DynGraph gr => Context a b -> gr a b -> gr a b -- graph folds and maps ufold :: Graph gr => ((Context a b) -> c -> c) -> c -> gr a b -> c gmap :: Graph gr => (Context a b -> Context c d) -> gr a b -> gr c d nmap :: Graph gr => (a -> c) -> gr a b -> gr c b emap :: Graph gr => (b -> c) -> gr a b -> gr a c -- graph projection matchAny :: Graph gr => gr a b -> GDecomp g a b nodes :: Graph gr => gr a b -> [Node] edges :: Graph gr => gr a b -> [Edge] labNodes :: Graph gr => gr a b -> [LNode a] labEdges :: Graph gr => gr a b -> [LEdge b] newNodes :: Graph gr => Int -> gr a b -> [Node] noNodes :: Graph gr => gr a b -> Int nodeRange :: Graph gr => gr a b -> (Node,Node) gelem :: Graph gr => Node -> gr a b -> Bool -- graph construction & destruction insNode :: DynGraph gr => LNode a -> gr a b -> gr a b insEdge :: DynGraph gr => LEdge b -> gr a b -> gr a b delNode :: Graph gr => Node -> gr a b -> gr a b delEdge :: DynGraph gr => Edge -> gr a b -> gr a b delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b insNodes :: DynGraph gr => [LNode a] -> gr a b -> gr a b insEdges :: DynGraph gr => [LEdge b] -> gr a b -> gr a b delNodes :: Graph gr => [Node] -> gr a b -> gr a b delEdges :: DynGraph gr => [Edge] -> gr a b -> gr a b buildGr :: DynGraph gr => [Context a b] -> gr a b mkUGraph :: DynGraph gr => [Node] -> [Edge] -> gr () () -- graph inspection context :: Graph gr => gr a b -> Node -> Context a b lab :: Graph gr => gr a b -> Node -> Maybe a neighbors :: Graph gr => gr a b -> Node -> [Node] suc :: Graph gr => gr a b -> Node -> [Node] pre :: Graph gr => gr a b -> Node -> [Node] lsuc :: Graph gr => gr a b -> Node -> [(Node,b)] lpre :: Graph gr => gr a b -> Node -> [(Node,b)] out :: Graph gr => gr a b -> Node -> [LEdge b] inn :: Graph gr => gr a b -> Node -> [LEdge b] outdeg :: Graph gr => gr a b -> Node -> Int indeg :: Graph gr => gr a b -> Node -> Int deg :: Graph gr => gr a b -> Node -> Int -- context inspection node' :: Context a b -> Node lab' :: Context a b -> a labNode' :: Context a b -> LNode a neighbors' :: Context a b -> [Node] suc' :: Context a b -> [Node] pre' :: Context a b -> [Node] lpre' :: Context a b -> [(Node,b)] lsuc' :: Context a b -> [(Node,b)] out' :: Context a b -> [LEdge b] inn' :: Context a b -> [LEdge b] outdeg' :: Context a b -> Int indeg' :: Context a b -> Int deg' :: Context a b -> Int -} -- | 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 [LNode a] instance Show a => Show (LPath a) where show (LP xs) = show xs -- | 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'. 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 -- essential operations -- | 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. mkGraph :: [LNode a] -> [LEdge b] -> gr a b -- | A list of all 'LNode's in the 'Graph'. labNodes :: gr a b -> [LNode a] -- derived operations -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node' -- and the remaining 'Graph'. matchAny :: gr a b -> GDecomp gr a b -- | The number of 'Node's in a 'Graph'. noNodes :: gr a b -> Int -- | The minimum and maximum 'Node' in a 'Graph'. nodeRange :: gr a b -> (Node,Node) -- | A list of all 'LEdge's in the 'Graph'. labEdges :: gr a b -> [LEdge b] -- default implementation of derived operations matchAny g = case labNodes g of [] -> error "Match Exception, Empty Graph" (v,_):_ -> (c,g') where (Just c,g') = match v g noNodes = length . labNodes nodeRange g = (minimum vs,maximum vs) where vs = map fst (labNodes g) labEdges = ufold (\(_,v,_,s)->((map (\(l,w)->(v,w,l)) s)++)) [] class Graph gr => DynGraph gr where -- | Merge the 'Context' into the 'DynGraph'. (&) :: Context a b -> gr a b -> gr a b -- | Fold a function over the graph. ufold :: Graph gr => ((Context a b) -> c -> c) -> c -> gr a b -> c ufold f u g | isEmpty g = u | otherwise = f c (ufold f u g') where (c,g') = matchAny g -- | Map a function over the graph. gmap :: DynGraph gr => (Context a b -> Context c d) -> gr a b -> gr c d gmap f = ufold (\c->(f c&)) empty -- | Map a function over the 'Node' labels in a graph. nmap :: DynGraph gr => (a -> c) -> gr a b -> gr c b nmap f = gmap (\(p,v,l,s)->(p,v,f l,s)) -- | Map a function over the 'Edge' labels in a graph. emap :: DynGraph gr => (b -> c) -> gr a b -> gr a c emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s)) where map1 g = map (\(l,v)->(g l,v)) -- | 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 (\(v,w,_)->(v,w)) . labEdges -- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'. newNodes :: Graph gr => Int -> gr a b -> [Node] newNodes i g = [n+1..n+i] where (_,n) = nodeRange g -- | 'True' if the 'Node' is present in the 'Graph'. gelem :: Graph gr => Node -> gr a b -> Bool gelem v g = case match v g of {(Just _,_) -> True; _ -> False} -- | Insert a 'LNode' into the 'Graph'. insNode :: DynGraph gr => LNode a -> gr a b -> gr a b insNode (v,l) = (([],v,l,[])&) -- | 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 (Just (pr,_,la,su),g') = match v g -- | 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'. 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'. delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b delLEdge (v,w,b) g = case match v g of (Nothing,_) -> g (Just (p,v',l,s),g') -> (p,v',l,filter (\(x,n) -> x /= b || n /= w) s) & g' -- | Insert multiple 'LNode's into the 'Graph'. insNodes :: DynGraph gr => [LNode a] -> gr a b -> gr a b insNodes vs g = foldr insNode g vs -- | Insert multiple 'LEdge's into the 'Graph'. insEdges :: DynGraph gr => [LEdge b] -> gr a b -> gr a b insEdges es g = foldr insEdge g es -- | Remove multiple 'Node's from the 'Graph'. delNodes :: Graph gr => [Node] -> gr a b -> gr a b delNodes [] g = g delNodes (v:vs) g = delNodes vs (snd (match v g)) -- | Remove multiple 'Edge's from the 'Graph'. delEdges :: DynGraph gr => [Edge] -> gr a b -> gr a b delEdges es g = foldr delEdge g es -- | Build a 'Graph' from a list of 'Context's. buildGr :: DynGraph gr => [Context a b] -> gr a b buildGr = foldr (&) empty -- mkGraph :: DynGraph gr => [LNode a] -> [LEdge b] -> gr a b -- mkGraph vs es = (insEdges es . insNodes vs) empty -- | Build a quasi-unlabeled 'Graph'. mkUGraph :: Graph gr => [Node] -> [Edge] -> gr () () mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es) where labUEdges = map (\(v,w)->(v,w,())) labUNodes = map (\v->(v,())) -- | Find the context for the given 'Node'. Causes an error if the 'Node' is -- not present in the 'Graph'. context :: Graph gr => gr a b -> Node -> Context a b context g v = case match v g of (Nothing,_) -> error ("Match Exception, Node: "++show v) (Just c,_) -> c -- | Find the label for a 'Node'. lab :: Graph gr => gr a b -> Node -> Maybe a lab g v = fst (match v g) >>= return.lab' -- | Find the neighbors for a 'Node'. neighbors :: Graph gr => gr a b -> Node -> [Node] neighbors = (\(p,_,_,s) -> map snd (p++s)) .: context -- | 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 = (\(p,_,_,s) -> length p+length s) .: 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 '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 -- graph equality -- nodeComp :: Eq b => LNode b -> LNode b -> Ordering nodeComp n@(v,_) n'@(w,_) | n == n' = EQ | v gr a b -> [LNode a] slabNodes = sortBy nodeComp . labNodes edgeComp :: Eq b => LEdge b -> LEdge b -> Ordering edgeComp e@(v,w,_) e'@(x,y,_) | e == e' = EQ | v gr a b -> [LEdge b] slabEdges = sortBy edgeComp . labEdges -- instance (Eq a,Eq b,Graph gr) => Eq (gr a b) where -- g == g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g' equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool equal g g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g' ---------------------------------------------------------------------- -- 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 = context1l' .: context context4l :: Graph gr => gr a b -> Node -> Adj b context4l = context4l' .: context 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 fgl-5.4.2.4/Data/Graph/Inductive/NodeMap.hs0000644000000000000000000002001211622121474016340 0ustar0000000000000000-- | 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 Prelude hiding (map) import qualified Prelude as P (map) import Control.Monad.State import Data.Graph.Inductive.Graph --import Data.Graph.Inductive.Tree import Data.Graph.Inductive.Internal.FiniteMap data (Ord a) => NodeMap a = NodeMap { map :: FiniteMap a Node, key :: Int } deriving Show -- | Create a new, empty mapping. new :: (Ord a) => NodeMap a new = NodeMap { map = emptyFM, 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') = (addToFM m' a n, max n k') (m, k) = foldr aux (emptyFM, 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 lookupFM mp a of Just i -> ((i, a), m) Nothing -> let m' = NodeMap { map = addToFM mp a k, key = k+1 } in ((k, a), m') -- | 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 <- lookupFM m a1 n2 <- lookupFM m a2 return (n1, n2, b) -- | Generates a list of 'LEdge's. mkEdges :: (Ord a) => NodeMap a -> [(a, a, b)] -> Maybe [LEdge b] mkEdges m es = mapM (mkEdge m) es -- | 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 :: (Ord a, DynGraph g) => (NodeMap a -> c -> (d, NodeMap a)) -> c -> NodeMapM a b g d liftN2 f c = do (m, g) <- get let (r, m') = f m c put (m', g) return r liftN2' :: (Ord a, DynGraph g) => (NodeMap a -> c -> d) -> c -> NodeMapM a b g d liftN2' 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 :: (Ord a, DynGraph g) => (NodeMap a -> c -> g a b -> g a b) -> c -> NodeMapM a b g () liftM1 f c = do (m, g) <- get let g' = f m c g put (m, g') liftM1' :: (Ord a, DynGraph g) => (NodeMap a -> c -> g a b -> (g a b, NodeMap a, d)) -> c -> NodeMapM a b g d liftM1' 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, DynGraph g) => a -> NodeMapM a b g (LNode a) mkNodeM = liftN2 mkNode mkNodesM :: (Ord a, DynGraph g) => [a] -> NodeMapM a b g [LNode a] mkNodesM = liftN2 mkNodes mkEdgeM :: (Ord a, DynGraph g) => (a, a, b) -> NodeMapM a b g (Maybe (LEdge b)) mkEdgeM = liftN2' mkEdge mkEdgesM :: (Ord a, DynGraph g) => [(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.4.2.4/Data/Graph/Inductive/PatriciaTree.hs0000644000000000000000000001323411622121474017401 0ustar0000000000000000{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -- |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 Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.List import Data.Maybe import Control.Arrow(second) newtype Gr a b = Gr (GraphRep a b) type GraphRep a b = IntMap (Context' a b) type Context' a b = (IntMap [b], a, IntMap [b]) type UGr = Gr () () instance Graph Gr where -- required members empty = Gr IM.empty isEmpty (Gr g) = IM.null g match = matchGr mkGraph vs es = (insEdges' . insNodes vs) empty where insEdges' g = foldl' (flip insEdge) g es labNodes (Gr g) = [ (node, label) | (node, (_, label, _)) <- IM.toList g ] -- overriding members for efficiency noNodes (Gr g) = IM.size g nodeRange (Gr g) | IM.null g = (0, 0) | otherwise = (ix (IM.minViewWithKey g), ix (IM.maxViewWithKey g)) where ix = fst . fst . fromJust labEdges (Gr g) = do (node, (_, _, s)) <- IM.toList g (next, labels) <- IM.toList s label <- labels return (node, next, label) instance DynGraph Gr where (p, v, l, s) & (Gr g) = let !g1 = IM.insert v (fromAdj p, l, fromAdj s) g !g2 = addSucc g1 v p !g3 = addPred g2 v s in Gr g3 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 (IM.keys s') !g3 = clearSucc g2 node (IM.keys p') in (Just (toAdj p', node, label, toAdj s), Gr g3) {-# 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 addSucc' v g g2 = IM.adjust addPred' w g1 addSucc' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss) addPred' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss) {-# RULES "gmap/Data.Graph.Inductive.PatriciaTree" gmap = fastGMap #-} fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d fastGMap f (Gr g) = Gr (IM.mapWithKey f' g) where f' :: Node -> Context' a b -> Context' c d f' = ((fromContext . f) .) . toContext {-# 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) toAdj :: IntMap [b] -> Adj b toAdj = concatMap expand . IM.toList where expand (n,ls) = map (flip (,) n) ls fromAdj :: Adj b -> IntMap [b] fromAdj = IM.fromListWith addLists . map (second return . swap) 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 :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b addSucc g _ [] = g addSucc g v ((l, p) : rest) = addSucc g' v rest where g' = IM.adjust f p g f (ps, l', ss) = (ps, l', IM.insertWith addLists v [l] ss) addPred :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b addPred g _ [] = g addPred g v ((l, s) : rest) = addPred g' v rest where g' = IM.adjust f s g f (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss) clearSucc :: GraphRep a b -> Node -> [Node] -> GraphRep a b clearSucc g _ [] = g clearSucc g v (p:rest) = clearSucc g' v rest where g' = IM.adjust f p g f (ps, l, ss) = (ps, l, IM.delete v ss) clearPred :: GraphRep a b -> Node -> [Node] -> GraphRep a b clearPred g _ [] = g clearPred g v (s:rest) = clearPred g' v rest where g' = IM.adjust f s g f (ps, l, ss) = (IM.delete v ps, l, ss) fgl-5.4.2.4/Data/Graph/Inductive/Query.hs0000644000000000000000000000220511622121474016126 0ustar0000000000000000module Data.Graph.Inductive.Query( module Data.Graph.Inductive.Query.DFS, module Data.Graph.Inductive.Query.BFS, module Data.Graph.Inductive.Query.SP, module Data.Graph.Inductive.Query.GVD, module Data.Graph.Inductive.Query.MST, module Data.Graph.Inductive.Query.Indep, module Data.Graph.Inductive.Query.MaxFlow, module Data.Graph.Inductive.Query.MaxFlow2, module Data.Graph.Inductive.Query.ArtPoint, module Data.Graph.Inductive.Query.BCC, module Data.Graph.Inductive.Query.Dominators, module Data.Graph.Inductive.Query.TransClos, module Data.Graph.Inductive.Query.Monad, ) where import Data.Graph.Inductive.Query.DFS import Data.Graph.Inductive.Query.BFS import Data.Graph.Inductive.Query.SP import Data.Graph.Inductive.Query.GVD import Data.Graph.Inductive.Query.MST import Data.Graph.Inductive.Query.Indep import Data.Graph.Inductive.Query.MaxFlow import Data.Graph.Inductive.Query.MaxFlow2 import Data.Graph.Inductive.Query.ArtPoint import Data.Graph.Inductive.Query.BCC import Data.Graph.Inductive.Query.Dominators import Data.Graph.Inductive.Query.TransClos import Data.Graph.Inductive.Query.Monad fgl-5.4.2.4/Data/Graph/Inductive/Tree.hs0000644000000000000000000000606611622121474015731 0ustar0000000000000000-- (c) 1999 - 2002 by Martin Erwig [see file COPYRIGHT] -- | Tree-based implementation of 'Graph' and 'DynGraph' module Data.Graph.Inductive.Tree (Gr,UGr) where import Data.List (foldl') import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Internal.FiniteMap import Data.Maybe (fromJust) ---------------------------------------------------------------------- -- GRAPH REPRESENTATION ---------------------------------------------------------------------- data Gr a b = Gr (GraphRep a b) type GraphRep a b = FiniteMap Node (Context' a b) type Context' a b = (Adj b,a,Adj b) type UGr = Gr () () ---------------------------------------------------------------------- -- CLASS INSTANCES ---------------------------------------------------------------------- -- Show -- showsGraph :: (Show a,Show b) => GraphRep a b -> ShowS showsGraph Empty = id showsGraph (Node _ l (v,(_,l',s)) r) = showsGraph l . ('\n':) . shows v . (':':) . shows l' . ("->"++) . shows s . showsGraph r instance (Show a,Show b) => Show (Gr a b) where showsPrec _ (Gr g) = showsGraph g -- Graph -- instance Graph Gr where empty = Gr emptyFM isEmpty (Gr g) = case g of {Empty -> True; _ -> False} match = matchGr mkGraph vs es = (insEdges' . insNodes vs) empty where insEdges' g = foldl' (flip insEdge) g es labNodes (Gr g) = map (\(v,(_,l,_))->(v,l)) (fmToList g) -- more efficient versions of derived class members -- matchAny (Gr Empty) = error "Match Exception, Empty Graph" matchAny g@(Gr (Node _ _ (v,_) _)) = (c,g') where (Just c,g') = matchGr v g noNodes (Gr g) = sizeFM g nodeRange (Gr Empty) = (0,0) nodeRange (Gr g) = (ix (minFM g),ix (maxFM g)) where ix = fst.fromJust labEdges (Gr g) = concatMap (\(v,(_,_,s))->map (\(l,w)->(v,w,l)) s) (fmToList g) matchGr v (Gr g) = case splitFM g v of Nothing -> (Nothing,Gr g) Just (g',(_,(p,l,s))) -> (Just (p',v,l,s),Gr g2) where s' = filter ((/=v).snd) s p' = filter ((/=v).snd) p g1 = updAdj g' s' (clearPred v) g2 = updAdj g1 p' (clearSucc v) -- DynGraph -- instance DynGraph Gr where (p,v,l,s) & (Gr g) | elemFM g v = error ("Node Exception, Node: "++show v) | otherwise = Gr g3 where g1 = addToFM g v (p,l,s) g2 = updAdj g1 p (addSucc v) g3 = updAdj g2 s (addPred v) ---------------------------------------------------------------------- -- UTILITIES ---------------------------------------------------------------------- addSucc v l (p,l',s) = (p,l',(l,v):s) addPred v l (p,l',s) = ((l,v):p,l',s) clearSucc v _ (p,l,s) = (p,l,filter ((/=v).snd) s) clearPred v _ (p,l,s) = (filter ((/=v).snd) p,l,s) updAdj :: GraphRep a b -> Adj b -> (b -> Context' a b -> Context' a b) -> GraphRep a b updAdj g [] _ = g updAdj g ((l,v):vs) f | elemFM g v = updAdj (updFM g v (f l)) vs f | otherwise = error ("Edge Exception, Node: "++show v) fgl-5.4.2.4/Data/Graph/Inductive/Basic.hs0000644000000000000000000000777111622121474016057 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 (threadMaybe,threadList) 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 f c = threadMaybe f c match -- gfold1 f d b u = threadGraph (\c->d (labNode' c)) (\c->gfoldn f d b u (f c)) gfold1 f d b = threadGraph d (\c->gfoldn f d b (f c)) 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.4.2.4/Data/Graph/Inductive/Example.hs0000644000000000000000000001735311622121474016426 0ustar0000000000000000-- | 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 import Data.Graph.Inductive.Tree 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.4.2.4/Data/Graph/Inductive/Monad.hs0000644000000000000000000001504011622121474016060 0ustar0000000000000000-- (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 ---------------------------------------------------------------------- -- MONADIC GRAPH CLASS ---------------------------------------------------------------------- -- -- Currently, we define just one monadic graph class: -- -- GraphM: static, decomposable graphs -- static means that a graph itself cannot be changed -- -- Later we might also define DynGraphM for dynamic, extensible graphs -- -- Monadic Graph -- class Monad m => GraphM m gr where -- essential operations emptyM :: m (gr a b) isEmptyM :: m (gr a b) -> m Bool matchM :: Node -> m (gr a b) -> m (Decomp gr a b) mkGraphM :: [LNode a] -> [LEdge b] -> m (gr a b) labNodesM :: m (gr a b) -> m [LNode a] -- derived operations matchAnyM :: m (gr a b) -> m (GDecomp gr a b) noNodesM :: m (gr a b) -> m Int nodeRangeM :: m (gr a b) -> m (Node,Node) labEdgesM :: m (gr a b) -> m [LEdge b] -- default implementation of derived operations matchAnyM g = do vs <- labNodesM g case vs of [] -> error "Match Exception, Empty Graph" (v,_):_ -> do (Just c,g') <- matchM v g return (c,g') noNodesM = labNodesM >>. length nodeRangeM g = do vs <- labNodesM g let vs' = map fst vs return (minimum vs',maximum vs') labEdgesM = ufoldM (\(p,v,_,s)->(((map (i v) p)++(map (o v) s))++)) [] where o v = \(l,w)->(v,w,l) i v = \(l,w)->(w,v,l) -- 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 (_,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 = map (\(v,w)->(v,w,())) 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.4.2.4/Data/Graph/Inductive/Internal/0000755000000000000000000000000011622121474016242 5ustar0000000000000000fgl-5.4.2.4/Data/Graph/Inductive/Internal/RootPath.hs0000644000000000000000000000271711622121474020345 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 instance Eq a => Eq (LPath a) where (LP []) == (LP []) = True (LP ((_,x):_)) == (LP ((_,y):_)) = x==y (LP _) == (LP _) = False instance Ord a => Ord (LPath a) where compare (LP []) (LP []) = EQ compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y compare _ _ = error "LPath: cannot compare to empty paths" type LRTree a = [LPath a] type RTree = [Path] 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 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 getDistance :: Node -> LRTree a -> a getDistance v = snd . head . findP v getLPathNodes :: Node -> LRTree a -> Path getLPathNodes v = (\(LP p)->map fst p) . getLPath v fgl-5.4.2.4/Data/Graph/Inductive/Internal/Thread.hs0000644000000000000000000001073011622121474020006 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.4.2.4/Data/Graph/Inductive/Internal/Heap.hs0000644000000000000000000000476111622121474017463 0ustar0000000000000000-- | Pairing heap implementation of dictionary module Data.Graph.Inductive.Internal.Heap( -- * Type Heap(..), -- * Operations empty,unit,insert,merge,mergeAll, isEmpty,findMin,deleteMin,splitMin, build, toList, heapsort ) where data Ord a => Heap a b = Empty | Node a b [Heap a b] deriving Eq showsHeap :: (Show a,Ord a,Show b) => Heap a b -> ShowS showsHeap Empty = id showsHeap (Node key val []) = shows key . (": "++) . shows val showsHeap (Node key val hs) = shows key . (": "++) . shows val . (' ':) . shows hs instance (Show a,Ord a,Show b) => Show (Heap a b) where showsPrec _ d = showsHeap d ---------------------------------------------------------------------- -- MAIN FUNCTIONS ---------------------------------------------------------------------- empty :: Ord a => Heap a b empty = Empty unit :: Ord a => a -> b -> Heap a b unit key val = Node key val [] insert :: Ord a => (a, b) -> Heap a b -> Heap a b insert (key, val) h = merge (unit key val) h 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 :: Ord a => Heap a b -> Bool isEmpty Empty = True isEmpty _ = False findMin :: Ord a => 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.4.2.4/Data/Graph/Inductive/Internal/Queue.hs0000644000000000000000000000130411622121474017660 0ustar0000000000000000module Data.Graph.Inductive.Internal.Queue( -- * Type Queue(..), -- * Operations mkQueue, queuePut, queuePutList, queueGet, queueEmpty ) where 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 [] q = q queuePutList (x:xs) q = queuePutList xs (queuePut x q) 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.4.2.4/Data/Graph/Inductive/Internal/FiniteMap.hs0000644000000000000000000001650311622121474020457 0ustar0000000000000000-- | Simple Finite Maps. -- This implementation provides several useful methods that Data.FiniteMap -- does not. module Data.Graph.Inductive.Internal.FiniteMap( -- * Type FiniteMap(..), -- * Operations emptyFM,addToFM,delFromFM, updFM, accumFM, splitFM, isEmptyFM,sizeFM,lookupFM,elemFM, rangeFM, minFM,maxFM,predFM,succFM, splitMinFM, fmToList ) where import Data.Maybe (isJust) data Ord a => FiniteMap a b = Empty | Node Int (FiniteMap a b) (a,b) (FiniteMap a b) deriving (Eq) ---------------------------------------------------------------------- -- UTILITIES ---------------------------------------------------------------------- -- pretty printing -- showsMap :: (Show a,Show b,Ord a) => FiniteMap a b -> ShowS showsMap Empty = id showsMap (Node _ l (i,x) r) = showsMap l . (' ':) . shows i . ("->"++) . shows x . showsMap r instance (Show a,Show b,Ord a) => Show (FiniteMap a b) where showsPrec _ m = showsMap m -- other -- splitMax :: Ord a => FiniteMap a b -> (FiniteMap a b,(a,b)) splitMax (Node _ l x Empty) = (l,x) splitMax (Node _ l x r) = (avlBalance l x m,y) where (m,y) = splitMax r splitMax Empty = error "splitMax on empty FiniteMap" merge :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b merge l Empty = l merge Empty r = r merge l r = avlBalance l' x r where (l',x) = splitMax l ---------------------------------------------------------------------- -- MAIN FUNCTIONS ---------------------------------------------------------------------- emptyFM :: Ord a => FiniteMap a b emptyFM = Empty addToFM :: Ord a => FiniteMap a b -> a -> b -> FiniteMap a b addToFM Empty i x = node Empty (i,x) Empty addToFM (Node h l (j,y) r) i x | ij = avlBalance l (j,y) (addToFM r i x) | otherwise = Node h l (j,x) r -- | applies function to stored entry updFM :: Ord a => FiniteMap a b -> a -> (b -> b) -> FiniteMap a b updFM Empty _ _ = Empty updFM (Node h l (j,x) r) i f | ij = let r' = updFM r i f in r' `seq` Node h l (j,x) r' | otherwise = Node h l (j,f x) r -- | defines or aggregates entries accumFM :: Ord a => FiniteMap a b -> a -> (b -> b -> b) -> b -> FiniteMap a b accumFM Empty i _ x = node Empty (i,x) Empty accumFM (Node h l (j,y) r) i f x | ij = avlBalance l (j,y) (accumFM r i f x) | otherwise = Node h l (j,f x y) r delFromFM :: Ord a => FiniteMap a b -> a -> FiniteMap a b delFromFM Empty _ = Empty delFromFM (Node _ l (j,x) r) i | ij = avlBalance l (j,x) (delFromFM r i) | otherwise = merge l r isEmptyFM :: FiniteMap a b -> Bool isEmptyFM Empty = True isEmptyFM _ = False sizeFM :: Ord a => FiniteMap a b -> Int sizeFM Empty = 0 sizeFM (Node _ l _ r) = sizeFM l + 1 + sizeFM r lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b lookupFM Empty _ = Nothing lookupFM (Node _ l (j,x) r) i | ij = lookupFM r i | otherwise = Just x -- | applies lookup to an interval rangeFM :: Ord a => FiniteMap a b -> a -> a -> [b] rangeFM m i j = rangeFMa m i j [] -- rangeFMa Empty _ _ a = a rangeFMa (Node _ l (k,x) r) i j a | kj = rangeFMa l i j a | otherwise = rangeFMa l i j (x:rangeFMa r i j a) minFM :: Ord a => FiniteMap a b -> Maybe (a,b) minFM Empty = Nothing minFM (Node _ Empty x _) = Just x minFM (Node _ l _ _) = minFM l maxFM :: Ord a => FiniteMap a b -> Maybe (a,b) maxFM Empty = Nothing maxFM (Node _ _ x Empty) = Just x maxFM (Node _ _ _ r) = maxFM r predFM :: Ord a => FiniteMap a b -> a -> Maybe (a,b) predFM m i = predFM' m i Nothing -- predFM' Empty _ p = p predFM' (Node _ l (j,x) r) i p | ij = predFM' r i (Just (j,x)) | isJust ml = ml | otherwise = p where ml = maxFM l succFM :: Ord a => FiniteMap a b -> a -> Maybe (a,b) succFM m i = succFM' m i Nothing -- succFM' Empty _ p = p succFM' (Node _ l (j,x) r) i p | ij = succFM' r i p | isJust mr = mr | otherwise = p where mr = minFM r elemFM :: Ord a => FiniteMap a b -> a -> Bool elemFM m i = case lookupFM m i of {Nothing -> False; _ -> True} -- | combines delFrom and lookup splitFM :: Ord a => FiniteMap a b -> a -> Maybe (FiniteMap a b,(a,b)) splitFM Empty _ = Nothing splitFM (Node _ l (j,x) r) i = if i Just (avlBalance l' (j,x) r,y) Nothing -> Nothing else if i>j then case splitFM r i of Just (r',y) -> Just (avlBalance l (j,x) r',y) Nothing -> Nothing else {- i==j -} Just (merge l r,(j,x)) -- | combines splitFM and minFM splitMinFM :: Ord a => FiniteMap a b -> Maybe (FiniteMap a b,(a,b)) splitMinFM Empty = Nothing splitMinFM (Node _ Empty x r) = Just (r,x) splitMinFM (Node _ l x r) = Just (avlBalance l' x r,y) where Just (l',y) = splitMinFM l fmToList :: Ord a => FiniteMap a b -> [(a,b)] fmToList m = scan m [] where scan Empty xs = xs scan (Node _ l x r) xs = scan l (x:(scan r xs)) ---------------------------------------------------------------------- -- AVL tree helper functions ---------------------------------------------------------------------- height :: Ord a => FiniteMap a b -> Int height Empty = 0 height (Node h _ _ _) = h node :: Ord a => FiniteMap a b -> (a,b) -> FiniteMap a b -> FiniteMap a b node l val r = Node h l val r where h=1+(height l `max` height r) avlBalance :: Ord a => FiniteMap a b -> (a,b) -> FiniteMap a b -> FiniteMap a b avlBalance l (i,x) r | (hr + 1 < hl) && (bias l < 0) = rotr (node (rotl l) (i,x) r) | (hr + 1 < hl) = rotr (node l (i,x) r) | (hl + 1 < hr) && (0 < bias r) = rotl (node l (i,x) (rotr r)) | (hl + 1 < hr) = rotl (node l (i,x) r) | otherwise = node l (i,x) r where hl=height l; hr=height r bias :: Ord a => FiniteMap a b -> Int bias (Node _ l _ r) = height l - height r bias Empty = 0 rotr :: Ord a => FiniteMap a b -> FiniteMap a b rotr Empty = Empty rotr (Node _ (Node _ l1 v1 r1) v2 r2) = node l1 v1 (node r1 v2 r2) rotr (Node _ Empty _ _) = error "rotr on invalid FiniteMap" rotl :: Ord a => FiniteMap a b -> FiniteMap a b rotl Empty = Empty rotl (Node _ l1 v1 (Node _ l2 v2 r2)) = node (node l1 v1 l2) v2 r2 rotl (Node _ _ _ Empty) = error "rotl on invalid FiniteMap" fgl-5.4.2.4/Data/Graph/Inductive/Monad/0000755000000000000000000000000011622121474015524 5ustar0000000000000000fgl-5.4.2.4/Data/Graph/Inductive/Monad/IOArray.hs0000644000000000000000000000750711622121474017377 0ustar0000000000000000-- (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 import Data.Maybe ---------------------------------------------------------------------- -- GRAPH REPRESENTATION ---------------------------------------------------------------------- data 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) instance (Show a,Show b) => Show (SGr a b) where show (SGr g) = showGraph g 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.4.2.4/Data/Graph/Inductive/Query/0000755000000000000000000000000011622121474015573 5ustar0000000000000000fgl-5.4.2.4/Data/Graph/Inductive/Query/BCC.hs0000644000000000000000000000527711622121474016531 0ustar0000000000000000module Data.Graph.Inductive.Query.BCC( bcc ) where import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Query.DFS import Data.Graph.Inductive.Query.ArtPoint ------------------------------------------------------------------------------ -- Given a graph g, this function computes the subgraphs which are -- g's connected components. ------------------------------------------------------------------------------ gComponents :: DynGraph gr => gr a b -> [gr a b] gComponents g = map (\(x,y)-> mkGraph x y) (zip ln le) where ln = map (\x->[(u,l)|(u,l)<-vs,elem u x]) cc le = map (\x->[(u,v,l)|(u,v,l)<-es,elem u x]) cc (vs,es,cc) = (labNodes g,labEdges g,components g) embedContexts :: DynGraph gr => Context a b -> [gr a b] -> [gr a b] embedContexts (_,v,l,s) gs = map (\(x,y)-> x & y) (zip lc gs) 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.4.2.4/Data/Graph/Inductive/Query/Dominators.hs0000644000000000000000000001172111622121474020250 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.Graph.Inductive.Graph import Data.Graph.Inductive.Query.DFS import Data.Tree (Tree(..)) import qualified Data.Tree as T import Data.Array import Data.IntMap (IntMap) import qualified Data.IntMap as I -- | 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 (iDom, toNode, fromNode) = idomWork g root dom' = getDom toNode iDom 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 iDom0 = array (1, s-1) (tail $ treeEdges (-1) ntree) -- fromNode translates graph nodes to relabeled (internal) nodes fromNode = I.unionWith const (I.fromList (zip (T.flatten tree) (T.flatten ntree))) (I.fromList (zip (nodes g) (repeat (-1)))) -- toNode translates internal nodes to graph nodes toNode = array (0, s-1) (zip (T.flatten ntree) (T.flatten tree)) preds = array (1, s-1) [(i, filter (/= -1) (map (fromNode I.!) (pre g (toNode ! i)))) | i <- [1..s-1]] -- iteratively improve the approximation to find iDom. iDom = fixEq (refineIDom preds) iDom0 in if null trees then error "Dominators.idomWork: root not in graph" else (iDom, toNode, fromNode) -- for each node in iDom, find the intersection of all its predecessor's -- dominating sets, and update iDom accordingly. refineIDom :: Preds -> IDom -> IDom refineIDom preds iDom = fmap (foldl1 (intersect iDom)) preds -- find the intersection of the two given dominance sets. intersect :: IDom -> Node' -> Node' -> Node' intersect iDom a b = case a `compare` b of LT -> intersect iDom a (iDom ! b) EQ -> a GT -> intersect iDom (iDom ! a) b -- convert an IDom to dominance sets. we translate to graph nodes here -- because mapping later would be more expensive and lose sharing. getDom :: ToNode -> IDom -> Array Node' [Node] getDom toNode iDom = let res = array (0, snd (bounds iDom)) ((0, [toNode ! 0]) : [(i, toNode ! i : res ! (iDom ! i)) | i <- range (bounds iDom)]) 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.4.2.4/Data/Graph/Inductive/Query/GVD.hs0000644000000000000000000000307411622121474016553 0ustar0000000000000000-- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT] -- | Graph Voronoi Diagram module Data.Graph.Inductive.Query.GVD ( Voronoi, gvdIn,gvdOut, voronoiSet,nearestNode,nearestDist,nearestPath, -- vd,nn,ns, -- vdO,nnO,nsO ) where import Data.Maybe (listToMaybe) import Data.List (nub) import qualified Data.Graph.Inductive.Internal.Heap as H import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Query.SP (dijkstra) import Data.Graph.Inductive.Internal.RootPath import Data.Graph.Inductive.Basic type Voronoi a = LRTree a gvdIn :: (DynGraph gr, Real b) => [Node] -> gr a b -> Voronoi b gvdIn vs g = gvdOut vs (grev g) gvdOut :: (Graph gr, Real b) => [Node] -> gr a b -> Voronoi b gvdOut vs = dijkstra (H.build (zip (repeat 0) (map (\v->LP [(v,0)]) vs))) voronoiSet :: Real b => Node -> Voronoi b -> [Node] voronoiSet v = nub . concat . filter (\p->last p==v) . map (\(LP p)->map fst p) maybePath :: Real b => Node -> Voronoi b -> Maybe (LPath b) maybePath v = listToMaybe . filter (\(LP ((w,_):_))->w==v) nearestNode :: Real b => Node -> Voronoi b -> Maybe Node nearestNode v = fmap (\(LP ((w,_):_))->w) . maybePath v nearestDist :: Real b => Node -> Voronoi b -> Maybe b nearestDist v = fmap (\(LP ((_,l):_))->l) . maybePath v nearestPath :: Real b => Node -> Voronoi b -> Maybe Path nearestPath v = fmap (\(LP p)->map fst p) . 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.4.2.4/Data/Graph/Inductive/Query/DFS.hs0000644000000000000000000001402011622121474016540 0ustar0000000000000000-- (c) 2000 - 2005 by Martin Erwig [see file COPYRIGHT] -- | Depth-First Search module Data.Graph.Inductive.Query.DFS( CFun, dfs,dfs',dff,dff', dfsWith, dfsWith',dffWith,dffWith', xdfsWith,xdfWith,xdffWith, -- * Undirected DFS udfs,udfs',udff,udff', -- * Reverse DFS rdff,rdff',rdfs,rdfs', -- * Applications of DFS\/DFF topsort,topsort',scc,reachable, -- * Applications of UDFS\/UDFF components,noComponents,isConnected ) where import Data.Tree import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Basic ---------------------------------------------------------------------- -- DFS AND FRIENDS ---------------------------------------------------------------------- {- Classification of all 32 dfs functions: dfs-function ::= [direction]"df"structure["With"]["'"] direction --> "x" | "u" | "r" structure --> "s" | "f" | structure direction | "s" "f" ------------------------ + optional With + optional ' "x" | xdfs xdff " " | dfs dff "u" | udfs udff "r" | rdfs rdff ------------------------ Direction Parameter ------------------- x : parameterized by a function that specifies which nodes to be visited next " ": the "normal case: just follow successors u : undirected, ie, follow predecesors and successors r : reverse, ie, follow predecesors Structure Parameter ------------------- s : result is a list of (a) objects computed from visited contexts ("With"-version) (b) nodes (normal version) f : result is a tree/forest of (a) objects computed from visited contexts ("With"-version) (b) nodes (normal version) Optional Suffixes ----------------- With : objects to be put into list/tree are given by a function on contexts, default for non-"With" versions: nodes ' : parameter node list is given implicitly by the nodes of the graph to be traversed, default for non-"'" versions: nodes must be provided explicitly Defined are only the following 18 most important function versions: xdfsWith dfsWith,dfsWith',dfs,dfs' udfs,udfs' rdfs,rdfs' xdffWith dffWith,dffWith',dff,dff' udff,udff' rdff,rdff' Others can be added quite easily if needed. -} -- fixNodes fixes the nodes of the graph as a parameter -- fixNodes :: Graph gr => ([Node] -> gr a b -> c) -> gr a b -> c fixNodes f g = f (nodes g) g -- generalized depth-first search -- (could also be simply defined as applying preorderF to the -- result of xdffWith) -- type CFun a b c = Context a b -> c xdfsWith :: Graph gr => CFun a b [Node] -> CFun a b c -> [Node] -> gr a b -> [c] 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' -- dfs -- 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 => [Node] -> gr a b -> [Node] dfs = dfsWith node' dfs' :: Graph gr => gr a b -> [Node] dfs' = dfsWith' node' -- undirected dfs, ie, ignore edge directions -- udfs :: Graph gr => [Node] -> gr a b -> [Node] udfs = xdfsWith neighbors' node' udfs' :: Graph gr => gr a b -> [Node] udfs' = fixNodes udfs -- reverse dfs, ie, follow predecessors -- rdfs :: Graph gr => [Node] -> gr a b -> [Node] rdfs = xdfsWith pre' node' rdfs' :: Graph gr => gr a b -> [Node] rdfs' = fixNodes rdfs -- generalized depth-first forest -- xdfWith :: Graph gr => CFun a b [Node] -> CFun a b c -> [Node] -> gr a b -> ([Tree c],gr a b) 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 xdffWith :: Graph gr => CFun a b [Node] -> CFun a b c -> [Node] -> gr a b -> [Tree c] xdffWith d f vs g = fst (xdfWith d f vs g) -- dff -- dffWith :: Graph gr => CFun a b c -> [Node] -> gr a b -> [Tree c] dffWith = xdffWith suc' dffWith' :: Graph gr => CFun a b c -> gr a b -> [Tree c] dffWith' f = fixNodes (dffWith f) dff :: Graph gr => [Node] -> gr a b -> [Tree Node] dff = dffWith node' dff' :: Graph gr => gr a b -> [Tree Node] dff' = dffWith' node' -- undirected dff -- udff :: Graph gr => [Node] -> gr a b -> [Tree Node] udff = xdffWith neighbors' node' udff' :: Graph gr => gr a b -> [Tree Node] udff' = fixNodes udff -- reverse dff, ie, following predecessors -- rdff :: Graph gr => [Node] -> gr a b -> [Tree Node] rdff = xdffWith pre' node' rdff' :: Graph gr => gr a b -> [Tree Node] rdff' = fixNodes rdff ---------------------------------------------------------------------- -- ALGORITHMS BASED ON DFS ---------------------------------------------------------------------- components :: Graph gr => gr a b -> [[Node]] components = (map preorder) . udff' noComponents :: Graph gr => gr a b -> Int noComponents = length . components isConnected :: Graph gr => gr a b -> Bool isConnected = (==1) . noComponents postflatten :: Tree a -> [a] postflatten (Node v ts) = postflattenF ts ++ [v] postflattenF :: [Tree a] -> [a] postflattenF = concatMap postflatten topsort :: Graph gr => gr a b -> [Node] topsort = reverse . postflattenF . dff' topsort' :: Graph gr => gr a b -> [a] topsort' = reverse . postorderF . (dffWith' lab') scc :: Graph gr => gr a b -> [[Node]] scc g = map preorder (rdff (topsort g) g) -- optimized, using rdff -- sccOrig g = map preorder (dff (topsort g) (grev g)) -- original by Sharir reachable :: Graph gr => Node -> gr a b -> [Node] reachable v g = preorderF (dff [v] g) fgl-5.4.2.4/Data/Graph/Inductive/Query/MaxFlow.hs0000644000000000000000000001354011622121474017507 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,Ord b) => [(Node,Node)] -> [(Node,Node,b)] getRevEdges [] = [] getRevEdges ((u,v):es) | notElem (v,u) 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,Ord b) => gr a b -> gr a (b,b,b) augmentGraph g = emap (\i->(i,0,i)) (insEdges (getRevEdges (edges g)) g) -- | Given a successor or predecessor list for node u and given node v, find -- the label corresponding to edge (u,v) and update the flow and residual -- capacity of that edge's label. Then return the updated list. updAdjList::(Num b,Ord b) => [((b,b,b),Node)]->Node->b->Bool->[((b,b,b),Node)] updAdjList s v cf fwd | fwd == True = ((x,y+cf,z-cf),w):rs | otherwise = ((x,y-cf,z+cf),w):rs where ((x,y,z),w) = head (filter (\(_,w')->v==w') s) rs = filter (\(_,w')->v/=w') s -- | Update flow and residual capacity along augmenting path from s to t in -- graph G. For a path [u,v,w,...] find the node u in G and its successor and -- predecessor list, then update the corresponding edges (u,v) and (v,u) on -- those lists by using the minimum residual capacity of the path. updateFlow :: (DynGraph gr,Num b,Ord b) => Path -> b -> gr a (b,b,b) -> gr a (b,b,b) updateFlow [] _ g = g 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 | augPath == [] = g | otherwise = mfmg (updateFlow augPath minC g) s t where minC = minimum (map ((\(_,_,z)->z).snd)(tail augLPath)) augPath = map fst augLPath LP augLPath = lesp s t gf gf = elfilter (\(_,_,z)->z/=0) g -- | Compute the flow from s to t on a graph whose edges are labeled with -- x, which is the max capacity and where not all edges need to be of the -- form a\<---->b. Return the flow as a grap whose edges are labeled with -- (x,y,z)=(max capacity,current flow,residual capacity) and all edges -- are of the form a\<---->b mf :: (DynGraph gr,Num b,Ord b) => gr a b -> Node -> Node -> gr a (b,b,b) mf g s t = mfmg (augmentGraph g) s t -- | Compute the maximum flow from s to t on a graph whose edges are labeled -- with x, which is the max capacity and where not all edges need to be of -- the form a\<---->b. Return the flow as a grap whose edges are labeled with -- (y,x) = (current flow, max capacity). maxFlowgraph :: (DynGraph gr,Num b,Ord b) => gr a b -> Node -> Node -> gr a (b,b) maxFlowgraph g s t = emap (\(u,v,_)->(v,u)) g2 where g2 = elfilter (\(x,_,_)->x/=0) g1 g1 = mf g s t -- | Compute the value of a maximumflow maxFlow :: (DynGraph gr,Num b,Ord b) => gr a b -> Node -> Node -> b maxFlow g s t = foldr (+) 0 (map (\(_,_,(x,_))->x)(out (maxFlowgraph g s t) s)) ------------------------------------------------------------------------------ -- 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.4.2.4/Data/Graph/Inductive/Query/Indep.hs0000644000000000000000000000123311622121474017165 0ustar0000000000000000-- (c) 2000 - 2002 by Martin Erwig [see file COPYRIGHT] -- | Maximum Independent Node Sets module Data.Graph.Inductive.Query.Indep ( indep ) where import Data.Graph.Inductive.Graph first :: (a -> Bool) -> [a] -> a first p = head . filter p indep :: DynGraph gr => gr a b -> [Node] indep g | isEmpty g = [] indep g = if length i1>length i2 then i1 else i2 where vs = nodes g m = maximum (map (deg g) vs) v = first (\v'->deg g v'==m) vs (Just c,g') = match v g i1 = indep g' i2 = v:indep (delNodes (neighbors' c) g') fgl-5.4.2.4/Data/Graph/Inductive/Query/BFS.hs0000644000000000000000000000772511622121474016554 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, -- * 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 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 g = bfenInternal (queuePutList vs mkQueue) g bfe :: Graph gr => Node -> gr a b -> [Edge] bfe v = bfen [(v,v)] outU c = map (\(v,w,_)->(v,w)) (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.4.2.4/Data/Graph/Inductive/Query/MST.hs0000644000000000000000000000245411622121474016577 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 ) where import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Internal.RootPath import qualified Data.Graph.Inductive.Internal.Heap as H newEdges :: Ord b => 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 g = prim (H.unit 0 (LP [(v,0)])) g msTree :: (Graph gr,Real b) => gr a b -> LRTree b msTree g = msTreeAt v g where ((_,v,_,_),_) = matchAny g msPath :: Real b => LRTree b -> Node -> Node -> Path msPath t a b = joinPaths (getLPathNodes a t) (getLPathNodes b t) joinPaths :: Path -> Path -> Path joinPaths p q = joinAt (head p) p q 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.4.2.4/Data/Graph/Inductive/Query/MaxFlow2.hs0000644000000000000000000002271311622121474017573 0ustar0000000000000000-- | Alternative Maximum Flow module Data.Graph.Inductive.Query.MaxFlow2( Network, ekSimple, ekFused, ekList, ) where -- ekSimple, ekFused, ekList) where import Data.List import Data.Maybe import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Tree import Data.Graph.Inductive.Internal.FiniteMap import Data.Graph.Inductive.Internal.Queue import Data.Graph.Inductive.Query.BFS (bft) ------------------------------------------------------------------------------ -- 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, Show) -- Data type for edge with direction of traversal type DirEdge b = (Node, Node, b, Direction) type DirPath=[(Node, Direction)] type DirRTree=[DirPath] pathFromDirPath = map (\(n,_)->n) ------------------------------------------------------------------------------ -- 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 (\(c,f)->(c>f)) 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 (\(c,f)->(c>f)) revExtract = extractEdge g v u (\(_,f)->(f>0)) -- 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 -- EXTRACT fglEdmondsList.txt setFromList :: Ord a => [a] -> FiniteMap a () setFromList [] = emptyFM setFromList (x:xs) = addToFM (setFromList xs) x () setContains :: Ord a => FiniteMap a () -> a -> Bool setContains m i = case (lookupFM m i) of Nothing -> False Just () -> True extractPathList :: [LEdge (Double, Double)] -> FiniteMap (Node,Node) () -> ([DirEdge (Double, Double)], [LEdge (Double, Double)]) extractPathList [] _ = ([], []) extractPathList (edge@(u,v,l@(c,f)):es) set | (c>f) && (setContains set (u,v)) = let (pathrest, notrest)=extractPathList es (delFromFM set (u,v)) in ((u,v,l,Forward):pathrest, notrest) | (f>0) && (setContains set (v,u)) = let (pathrest, notrest)=extractPathList es (delFromFM set (u,v)) 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) (setFromList (zip justPath (tail justPath))) delta = minimum $ getPathDeltas es justPath = pathFromDirPath (fromJust maybePath) ekList :: Network -> Node -> Node -> (Network, Double) ekList = ekWith ekStepList -- ENDEXTRACT fgl-5.4.2.4/Data/Graph/Inductive/Query/TransClos.hs0000644000000000000000000000124311622121474020037 0ustar0000000000000000module Data.Graph.Inductive.Query.TransClos( trc ) where import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Query.DFS (reachable) getNewEdges :: DynGraph gr => [LNode a] -> gr a b -> [LEdge ()] getNewEdges vs g = concatMap (\(u,_)->r u g) vs where r = \u g' -> map (\v->(u,v,())) (reachable u g') {-| Finds the transitive closure of a directed graph. Given a graph G=(V,E), its transitive closure is the graph: G* = (V,E*) where E*={(i,j): i,j in V and there is a path from i to j in G} -} trc :: DynGraph gr => gr a b -> gr a () trc g = insEdges (getNewEdges ln g) (insNodes ln empty) where ln = labNodes g fgl-5.4.2.4/Data/Graph/Inductive/Query/Monad.hs0000644000000000000000000001743611622121474017200 0ustar0000000000000000-- (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 Data.Tree --import Control.Monad (liftM) 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 ---------------------------------------------------------------------- data GT m g a = MGT (m g -> m (a,g)) apply :: GT m g a -> m g -> m (a,g) apply (MGT f) mg = f mg apply' :: 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 => 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 []) (do v <- getNode vs <- getNodes return (v:vs)) getNodes :: GraphM m gr => GT m (gr a b) [Node] getNodes = condMGT isEmptyM (return []) (do v <- getNode vs <- getNodes return (v:vs)) 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.4.2.4/Data/Graph/Inductive/Query/SP.hs0000644000000000000000000000213211622121474016447 0ustar0000000000000000-- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT] module Data.Graph.Inductive.Query.SP( spTree,spLength,sp, dijkstra ) 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 -- | Implementation of Dijkstra's shortest path algorithm dijkstra :: (Graph gr, Real b) => H.Heap b (LPath b) -> gr a b -> LRTree b dijkstra h g | H.isEmpty h || isEmpty g = [] dijkstra h g = case match v g of (Just c,g') -> p:dijkstra (H.mergeAll (h':expand d p c)) g' (Nothing,g') -> dijkstra h' g' where (_,p@(LP ((v,d):_)),h') = H.splitMin h spTree :: (Graph gr, Real b) => Node -> gr a b -> LRTree b spTree v = dijkstra (H.unit 0 (LP [(v,0)])) spLength :: (Graph gr, Real b) => Node -> Node -> gr a b -> b spLength s t = getDistance t . spTree s sp :: (Graph gr, Real b) => Node -> Node -> gr a b -> Path sp s t = getLPathNodes t . spTree s fgl-5.4.2.4/Data/Graph/Inductive/Query/ArtPoint.hs0000644000000000000000000001377411622121474017703 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) ------------------------------------------------------------------------------ -- 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) ------------------------------------------------------------------------------ -- 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) = length ch >= 1 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