From: ross Date: Thu, 3 Apr 2003 16:47:00 +0000 (+0000) Subject: [project @ 2003-04-03 16:46:59 by ross] X-Git-Tag: nhc98-1-18-release~705 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e6492fce6f70270acda18b5747f408d3add29724;p=haskell-directory.git [project @ 2003-04-03 16:46:59 by ross] Graph and Tree modules, from GHC's Digraph (actually the Haddock version, which looks more recent). --- diff --git a/Data/Graph.hs b/Data/Graph.hs new file mode 100644 index 0000000..130c7dd --- /dev/null +++ b/Data/Graph.hs @@ -0,0 +1,375 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Graph +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires non-portable module ST) +-- +-- A version of the graph algorithms described in: +-- +-- /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/, +-- by David King and John Launchbury. +-- +----------------------------------------------------------------------------- + +module Data.Graph( + + -- * External interface + + -- At present the only one with a "nice" external interface + stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs, + + -- * Graphs + + Graph, Table, Bounds, Edge, Vertex, + + -- ** Building graphs + + graphFromEdges, buildG, transposeG, + -- reverseE, + + -- ** Graph properties + + vertices, edges, + outdegree, indegree, + + -- * Algorithms + + dfs, dff, + topSort, + components, + scc, + bcc, + -- back, cross, forward, + reachable, path, + + module Data.Tree + + ) where + +-- Extensions +import Control.Monad.ST +import Data.Array.ST (STArray, newArray, readArray, writeArray) +import Data.Tree (Tree(Node), Forest) + +-- std interfaces +import Data.Maybe +import Data.Array +import Data.List + +------------------------------------------------------------------------- +-- - +-- External interface +-- - +------------------------------------------------------------------------- + +-- | Strongly connected component. +data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not + -- in any cycle. + | CyclicSCC [vertex] -- ^ A maximal set of mutually + -- reachable vertices. + +-- | The vertices of a list of strongly connected components. +flattenSCCs :: [SCC a] -> [a] +flattenSCCs = concatMap flattenSCC + +-- | The vertices of a strongly connected component. +flattenSCC :: SCC vertex -> [vertex] +flattenSCC (AcyclicSCC v) = [v] +flattenSCC (CyclicSCC vs) = vs + +-- | The strongly connected components of a directed graph, topologically +-- sorted. +stronglyConnComp + :: Ord key + => [(node, key, [key])] + -- ^ The graph: a list of nodes uniquely identified by keys, + -- with a list of keys of nodes this node has edges to. + -- The out-list may contain keys that don't correspond to + -- nodes of the graph; such edges are ignored. + -> [SCC node] + +stronglyConnComp edges0 + = map get_node (stronglyConnCompR edges0) + where + get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n + get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples] + +-- | The strongly connected components of a directed graph, topologically +-- sorted. The function is the same as 'stronglyConnComp', except that +-- all the information about each node retained. +-- The "R" interface is used when you expect to apply 'SCC' to +-- (some of) the result of 'SCC', so you don't want to lose the +-- dependency information. +stronglyConnCompR + :: Ord key + => [(node, key, [key])] + -- ^ The graph: a list of nodes uniquely identified by keys, + -- with a list of keys of nodes this node has edges to. + -- The out-list may contain keys that don't correspond to + -- nodes of the graph; such edges are ignored. + -> [SCC (node, key, [key])] -- ^ Topologically sorted + +stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF +stronglyConnCompR edges0 + = map decode forest + where + (graph, vertex_fn) = graphFromEdges edges0 + forest = scc graph + decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] + | otherwise = AcyclicSCC (vertex_fn v) + decode other = CyclicSCC (dec other []) + where + dec (Node v ts) vs = vertex_fn v : foldr dec vs ts + mentions_itself v = v `elem` (graph ! v) + +------------------------------------------------------------------------- +-- - +-- Graphs +-- - +------------------------------------------------------------------------- + +-- | Abstract representation of vertices. +type Vertex = Int +-- | Table indexed by a contiguous set of vertices. +type Table a = Array Vertex a +-- | Adjacency list representation of a graph, mapping each vertex to its +-- list of successors. +type Graph = Table [Vertex] +-- | The bounds of a 'Table'. +type Bounds = (Vertex, Vertex) +-- | An edge from the first vertex to the second. +type Edge = (Vertex, Vertex) + +-- | All vertices of a graph. +vertices :: Graph -> [Vertex] +vertices = indices + +-- | All edges of a graph. +edges :: Graph -> [Edge] +edges g = [ (v, w) | v <- vertices g, w <- g!v ] + +mapT :: (Vertex -> a -> b) -> Table a -> Table b +mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ] + +-- | Build a graph from a list of edges. +buildG :: Bounds -> [Edge] -> Graph +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0 + +-- | The graph obtained by reversing all edges. +transposeG :: Graph -> Graph +transposeG g = buildG (bounds g) (reverseE g) + +reverseE :: Graph -> [Edge] +reverseE g = [ (w, v) | (v, w) <- edges g ] + +-- | A table of the count of edges from each node. +outdegree :: Graph -> Table Int +outdegree = mapT numEdges + where numEdges _ ws = length ws + +-- | A table of the count of edges into each node. +indegree :: Graph -> Table Int +indegree = outdegree . transposeG + +-- | Build a graph from a list of nodes uniquely identified by keys, +-- with a list of keys of nodes this node should have edges to. +-- The out-list may contain keys that don't correspond to +-- nodes of the graph; they are ignored. +graphFromEdges + :: Ord key + => [(node, key, [key])] + -> (Graph, Vertex -> (node, key, [key])) +graphFromEdges edges0 + = (graph, \v -> vertex_map ! v) + where + max_v = length edges0 - 1 + bounds0 = (0,max_v) :: (Vertex, Vertex) + sorted_edges = sortBy lt edges0 + edges1 = zipWith (,) [0..] sorted_edges + + graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1] + key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1] + vertex_map = array bounds0 edges1 + + (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 + + -- key_vertex :: key -> Maybe Vertex + -- returns Nothing for non-interesting vertices + key_vertex k = findVertex 0 max_v + where + findVertex a b | a > b + = Nothing + findVertex a b = case compare k (key_map ! mid) of + LT -> findVertex a (mid-1) + EQ -> Just mid + GT -> findVertex (mid+1) b + where + mid = (a + b) `div` 2 + +------------------------------------------------------------------------- +-- - +-- Depth first search +-- - +------------------------------------------------------------------------- + +type Set s = STArray s Vertex Bool + +mkEmpty :: Bounds -> ST s (Set s) +mkEmpty bnds = newArray bnds False + +contains :: Set s -> Vertex -> ST s Bool +contains m v = readArray m v + +include :: Set s -> Vertex -> ST s () +include m v = writeArray m v True + +-- | A spanning forest of the graph, obtained from a depth-first search of +-- the graph starting from each vertex in an unspecified order. +dff :: Graph -> Forest Vertex +dff g = dfs g (vertices g) + +-- | A spanning forest of the part of the graph reachable from the listed +-- vertices, obtained from a depth-first search of the graph starting at +-- each of the listed vertices in order. +dfs :: Graph -> [Vertex] -> Forest Vertex +dfs g vs = prune (bounds g) (map (generate g) vs) + +generate :: Graph -> Vertex -> Tree Vertex +generate g v = Node v (map (generate g) (g!v)) + +prune :: Bounds -> Forest Vertex -> Forest Vertex +prune bnds ts = runST (mkEmpty bnds >>= \m -> + chop m ts) + +chop :: Set s -> Forest Vertex -> ST s (Forest Vertex) +chop _ [] = return [] +chop m (Node v ts : us) + = contains m v >>= \visited -> + if visited then + chop m us + else + include m v >>= \_ -> + chop m ts >>= \as -> + chop m us >>= \bs -> + return (Node v as : bs) + +------------------------------------------------------------------------- +-- - +-- Algorithms +-- - +------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Algorithm 1: depth first search numbering +------------------------------------------------------------ + +preorder :: Tree a -> [a] +preorder (Node a ts) = a : preorderF ts + +preorderF :: Forest a -> [a] +preorderF ts = concat (map preorder ts) + +tabulate :: Bounds -> [Vertex] -> Table Int +tabulate bnds vs = array bnds (zipWith (,) vs [1..]) + +preArr :: Bounds -> Forest Vertex -> Table Int +preArr bnds = tabulate bnds . preorderF + +------------------------------------------------------------ +-- Algorithm 2: topological sorting +------------------------------------------------------------ + +postorder :: Tree a -> [a] +postorder (Node a ts) = postorderF ts ++ [a] + +postorderF :: Forest a -> [a] +postorderF ts = concat (map postorder ts) + +postOrd :: Graph -> [Vertex] +postOrd = postorderF . dff + +-- | A topological sort of the graph. +-- The order is partially specified by the condition that a vertex /i/ +-- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa. +topSort :: Graph -> [Vertex] +topSort = reverse . postOrd + +------------------------------------------------------------ +-- Algorithm 3: connected components +------------------------------------------------------------ + +-- | The connected components of a graph. +-- Two vertices are connected if there is a path between them, traversing +-- edges in either direction. +components :: Graph -> Forest Vertex +components = dff . undirected + +undirected :: Graph -> Graph +undirected g = buildG (bounds g) (edges g ++ reverseE g) + +-- Algorithm 4: strongly connected components + +-- | The strongly connected components of a graph. +scc :: Graph -> Forest Vertex +scc g = dfs g (reverse (postOrd (transposeG g))) + +------------------------------------------------------------ +-- Algorithm 5: Classifying edges +------------------------------------------------------------ + +back :: Graph -> Table Int -> Graph +back g post = mapT select g + where select v ws = [ w | w <- ws, post!v < post!w ] + +cross :: Graph -> Table Int -> Table Int -> Graph +cross g pre post = mapT select g + where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ] + +forward :: Graph -> Graph -> Table Int -> Graph +forward g tree pre = mapT select g + where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v + +------------------------------------------------------------ +-- Algorithm 6: Finding reachable vertices +------------------------------------------------------------ + +-- | A list of vertices reachable from a given vertex. +reachable :: Graph -> Vertex -> [Vertex] +reachable g v = preorderF (dfs g [v]) + +-- | Is the second vertex reachable from the first? +path :: Graph -> Vertex -> Vertex -> Bool +path g v w = w `elem` (reachable g v) + +------------------------------------------------------------ +-- Algorithm 7: Biconnected components +------------------------------------------------------------ + +-- | The biconnected components of a graph. +-- An undirected graph is biconnected if the deletion of any vertex +-- leaves it connected. +bcc :: Graph -> Forest [Vertex] +bcc g = (concat . map bicomps . map (do_label g dnum)) forest + where forest = dff g + dnum = preArr (bounds g) forest + +do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int) +do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us + where us = map (do_label g dnum) ts + lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v] + ++ [lu | Node (u,du,lu) xs <- us]) + +bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex] +bicomps (Node (v,_,_) ts) + = [ Node (v:vs) us | (l,Node vs us) <- map collect ts] + +collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex]) +collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs) + where collected = map collect ts + vs = concat [ ws | (lw, Node ws us) <- collected, lw b) -> (Tree a -> Tree b) +mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts) + +instance Show a => Show (Tree a) where + show = showTree + showList ts s = showForest ts ++ s + +showTree :: Show a => Tree a -> String +showTree = drawTree . mapTree show + +showForest :: Show a => Forest a -> String +showForest = unlines . map showTree + +drawTree :: Tree String -> String +drawTree = unlines . draw + +draw :: Tree String -> [String] +draw (Node x ts0) = grp this (space (length this)) (stLoop ts0) + where this = s1 ++ x ++ " " + + space n = replicate n ' ' + + stLoop [] = [""] + stLoop [t] = grp s2 " " (draw t) + stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts + + rsLoop [] = error "rsLoop:Unexpected empty list." + rsLoop [t] = grp s5 " " (draw t) + rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts + + grp fst0 rst = zipWith (++) (fst0:repeat rst) + + [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"] + +-- | The elements of a tree in pre-order. +flatten :: Tree a -> [a] +flatten t = squish t [] + where squish (Node x ts) xs = x:foldr squish xs ts + +-- | Lists of nodes at each level of the tree. +levels :: Tree a -> [[a]] +levels t = map (map root) $ takeWhile (not . null) $ iterate subforest [t] + where root (Node x _) = x + subforest f = [t | Node _ ts <- f, t <- ts]