diff --git a/Data/Graph/Inductive.hs b/Data/Graph/Inductive.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive.hs @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- +-- Inductive.hs -- Functional Graph Library +-- +-- (c) 1999-2006 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, June 2006" diff --git a/Data/Graph/Inductive/Basic.hs b/Data/Graph/Inductive/Basic.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Basic.hs @@ -0,0 +1,126 @@ +-- (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 diff --git a/Data/Graph/Inductive/Example.hs b/Data/Graph/Inductive/Example.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Example.hs @@ -0,0 +1,187 @@ +-- | 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)] + diff --git a/Data/Graph/Inductive/Graph.hs b/Data/Graph/Inductive/Graph.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Graph.hs @@ -0,0 +1,476 @@ +-- (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,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) + +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 .: context4 + +-- | Find all 'Node's that link to to the given 'Node'. +pre :: Graph gr => gr a b -> Node -> [Node] +pre = map snd .: context1 + +-- | 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 .: context4 + +-- | 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 .: context1 + +-- | 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)) (context4 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)) (context1 g v) + +-- | The outward-bound degree of the 'Node'. +outdeg :: Graph gr => gr a b -> Node -> Int +outdeg = length .: context4 + +-- | The inward-bound degree of the 'Node'. +indeg :: Graph gr => gr a b -> Node -> Int +indeg = length .: context1 + +-- | 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' (_,_,_,s) = map snd s + +-- | All 'Node's linked from in a 'Context'. +pre' :: Context a b -> [Node] +pre' (p,_,_,_) = map snd p + +-- | All 'Node's linked from in a 'Context', and the label of the links. +lpre' :: Context a b -> [(Node,b)] +lpre' (p,_,_,_) = map flip2 p + +-- | All 'Node's linked from in a 'Context', and the label of the links. +lsuc' :: Context a b -> [(Node,b)] +lsuc' (_,_,_,s) = map flip2 s + +-- | All outward-directed 'LEdge's in a 'Context'. +out' :: Context a b -> [LEdge b] +out' (_,v,_,s) = map (\(l,w)->(v,w,l)) s + +-- | All inward-directed 'LEdge's in a 'Context'. +inn' :: Context a b -> [LEdge b] +inn' (p,v,_,_) = map (\(l,w)->(w,v,l)) p + +-- | The outward degree of a 'Context'. +outdeg' :: Context a b -> Int +outdeg' (_,_,_,s) = length s + +-- | The inward degree of a 'Context'. +indeg' :: Context a b -> Int +indeg' (p,_,_,_) = length p + +-- | 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 .) .) +-- (.:) = (.) (.) (.) +(.:) = (.) . (.) + +fst4 (x,_,_,_) = x +{- not used +snd4 (_,x,_,_) = x +thd4 (_,_,x,_) = x +-} +fth4 (_,_,_,x) = x + +{- not used +fst3 (x,_,_) = x +snd3 (_,x,_) = x +thd3 (_,_,x) = x +-} + +flip2 (x,y) = (y,x) + + +-- projecting on context elements +-- +-- context1 g v = fst4 (contextP g v) +context1 :: Graph gr => gr a b -> Node -> Adj b +{- not used +context2 :: Graph gr => gr a b -> Node -> Node +context3 :: Graph gr => gr a b -> Node -> a +-} +context4 :: Graph gr => gr a b -> Node -> Adj b + +context1 = fst4 .: context +{- not used +context2 = snd4 .: context +context3 = thd4 .: context +-} +context4 = fth4 .: context + diff --git a/Data/Graph/Inductive/Graphviz.hs b/Data/Graph/Inductive/Graphviz.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Graphviz.hs @@ -0,0 +1,69 @@ +-- | 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) | 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 "" diff --git a/Data/Graph/Inductive/Internal/FiniteMap.hs b/Data/Graph/Inductive/Internal/FiniteMap.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Internal/FiniteMap.hs @@ -0,0 +1,209 @@ +-- | 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" diff --git a/Data/Graph/Inductive/Internal/Heap.hs b/Data/Graph/Inductive/Internal/Heap.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Internal/Heap.hs @@ -0,0 +1,91 @@ +-- | 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' +-} diff --git a/Data/Graph/Inductive/Internal/Queue.hs b/Data/Graph/Inductive/Internal/Queue.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Internal/Queue.hs @@ -0,0 +1,26 @@ +module 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) diff --git a/Data/Graph/Inductive/Internal/RootPath.hs b/Data/Graph/Inductive/Internal/RootPath.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Internal/RootPath.hs @@ -0,0 +1,51 @@ +-- (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 diff --git a/Data/Graph/Inductive/Internal/Thread.hs b/Data/Graph/Inductive/Internal/Thread.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Internal/Thread.hs @@ -0,0 +1,149 @@ +-- (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 +-} diff --git a/Data/Graph/Inductive/Monad.hs b/Data/Graph/Inductive/Monad.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Monad.hs @@ -0,0 +1,227 @@ +-- (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' + + +-} diff --git a/Data/Graph/Inductive/Monad/IOArray.hs b/Data/Graph/Inductive/Monad/IOArray.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Monad/IOArray.hs @@ -0,0 +1,112 @@ +-- (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)}) + + + diff --git a/Data/Graph/Inductive/NodeMap.hs b/Data/Graph/Inductive/NodeMap.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/NodeMap.hs @@ -0,0 +1,248 @@ +-- | 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 diff --git a/Data/Graph/Inductive/Query.hs b/Data/Graph/Inductive/Query.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query.hs @@ -0,0 +1,29 @@ +module Data.Graph.Inductive.Query( + module Data.Graph.Inductive.Query.DFS, + module Data.Graph.Inductive.Query.BFS, + module Data.Graph.Inductive.Query.SP, + module Data.Graph.Inductive.Query.GVD, + module Data.Graph.Inductive.Query.MST, + module Data.Graph.Inductive.Query.Indep, + module Data.Graph.Inductive.Query.MaxFlow, + module Data.Graph.Inductive.Query.MaxFlow2, + module Data.Graph.Inductive.Query.ArtPoint, + module Data.Graph.Inductive.Query.BCC, + module Data.Graph.Inductive.Query.Dominators, + module Data.Graph.Inductive.Query.TransClos, + module Data.Graph.Inductive.Query.Monad, +) where + +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 diff --git a/Data/Graph/Inductive/Query/ArtPoint.hs b/Data/Graph/Inductive/Query/ArtPoint.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/ArtPoint.hs @@ -0,0 +1,122 @@ +module 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 + diff --git a/Data/Graph/Inductive/Query/BCC.hs b/Data/Graph/Inductive/Query/BCC.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/BCC.hs @@ -0,0 +1,75 @@ +module 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 functions returns the graph which +-- v belongs to. +------------------------------------------------------------------------------ +findGraph :: DynGraph gr => Node -> [gr a b] -> Decomp gr a b +findGraph _ [] = error "findGraph: empty graph list" +findGraph v (g:gs) = case match v g of + (Nothing, _) -> findGraph v gs + (Just c, g') -> (Just c, g') + +------------------------------------------------------------------------------ +-- 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 (g:gs) (v:vs) = splitGraphs (gs''++gs) vs + where gs'' = embedContexts c gs' + gs' = gComponents g' + (Just c,g') = findGraph v (g: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) + + + + + + + + + + + + + + + + + + + diff --git a/Data/Graph/Inductive/Query/BFS.hs b/Data/Graph/Inductive/Query/BFS.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/BFS.hs @@ -0,0 +1,131 @@ +-- (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 + diff --git a/Data/Graph/Inductive/Query/DFS.hs b/Data/Graph/Inductive/Query/DFS.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/DFS.hs @@ -0,0 +1,222 @@ +-- (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', + -- * 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) + diff --git a/Data/Graph/Inductive/Query/Dominators.hs b/Data/Graph/Inductive/Query/Dominators.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/Dominators.hs @@ -0,0 +1,40 @@ +module Data.Graph.Inductive.Query.Dominators( + dom +) where + +import Data.List +import Data.Graph.Inductive.Graph + + +type DomSets = [(Node,[Node],[Node])] + + +intersection :: [[Node]] -> [Node] +intersection cs = foldr intersect (head cs) cs + +getdomv :: [Node] -> DomSets -> [[Node]] +getdomv vs ds = [z|(w,_,z)<-ds,v<-vs,v==w] + +builddoms :: DomSets -> [Node] -> DomSets +builddoms ds [] = ds +builddoms ds (v:vs) = builddoms ((fs++[(n,p,sort(n:idv))])++(tail rs)) vs + where idv = intersection (getdomv p ds) + (n,p,_) = head rs + (fs,rs) = span (\(x,_,_)->x/=v) ds + +domr :: DomSets -> [Node] -> DomSets +domr ds vs|xs == ds = ds + |otherwise = builddoms xs vs + where xs = (builddoms ds vs) + +{-| +Finds the dominators relationship for a given graph and an initial +node. For each node v, it returns the list of dominators of v. +-} +dom :: Graph gr => gr a b -> Node -> [(Node,[Node])] +dom g u = map (\(x,_,z)->(x,z)) (domr ld n') + where ld = (u,[],[u]):map (\v->(v,pre g v,n)) (n') + n' = n\\[u] + n = nodes g + + diff --git a/Data/Graph/Inductive/Query/GVD.hs b/Data/Graph/Inductive/Query/GVD.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/GVD.hs @@ -0,0 +1,51 @@ +-- (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] diff --git a/Data/Graph/Inductive/Query/Indep.hs b/Data/Graph/Inductive/Query/Indep.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/Indep.hs @@ -0,0 +1,24 @@ +-- (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') + diff --git a/Data/Graph/Inductive/Query/MST.hs b/Data/Graph/Inductive/Query/MST.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/MST.hs @@ -0,0 +1,41 @@ +-- (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) + diff --git a/Data/Graph/Inductive/Query/MaxFlow.hs b/Data/Graph/Inductive/Query/MaxFlow.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/MaxFlow.hs @@ -0,0 +1,127 @@ +-- | 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) +------------------------------------------------------------------------------ + + diff --git a/Data/Graph/Inductive/Query/MaxFlow2.hs b/Data/Graph/Inductive/Query/MaxFlow2.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/MaxFlow2.hs @@ -0,0 +1,263 @@ +-- | 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 + diff --git a/Data/Graph/Inductive/Query/Monad.hs b/Data/Graph/Inductive/Query/Monad.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/Monad.hs @@ -0,0 +1,227 @@ +-- (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} + diff --git a/Data/Graph/Inductive/Query/SP.hs b/Data/Graph/Inductive/Query/SP.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/SP.hs @@ -0,0 +1,32 @@ +-- (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 diff --git a/Data/Graph/Inductive/Query/TransClos.hs b/Data/Graph/Inductive/Query/TransClos.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Query/TransClos.hs @@ -0,0 +1,21 @@ +module 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 + diff --git a/Data/Graph/Inductive/Tree.hs b/Data/Graph/Inductive/Tree.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Inductive/Tree.hs @@ -0,0 +1,99 @@ +-- (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) + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 1999-2004, Martin Erwig +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fgl.cabal b/fgl.cabal new file mode 100644 --- /dev/null +++ b/fgl.cabal @@ -0,0 +1,39 @@ +name: fgl +version: 5.3 +license: BSD3 +license-file: LICENSE +maintainer: Martin Erwig +homepage: http://web.engr.oregonstate.edu/~erwig/fgl/haskell +category: Data Structures +synopsis: Martin Erwig's Functional Graph Library +exposed-modules: + Data.Graph.Inductive.Internal.FiniteMap, + Data.Graph.Inductive.Internal.Heap, + Data.Graph.Inductive.Internal.Queue, + Data.Graph.Inductive.Internal.RootPath, + Data.Graph.Inductive.Internal.Thread, + Data.Graph.Inductive.Basic, + Data.Graph.Inductive.Example, + Data.Graph.Inductive.Graph, + Data.Graph.Inductive.Graphviz, + Data.Graph.Inductive.Monad, + Data.Graph.Inductive.NodeMap, + Data.Graph.Inductive.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, mtl +extensions: MultiParamTypeClasses, OverlappingInstances