2 % (c) The University of Glasgow 2006
7 Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices,
9 SCC(..), flattenSCC, flattenSCCs,
10 stronglyConnCompG, topologicalSortG,
11 verticesG, edgesG, hasVertexG,
12 reachableG, transposeG,
13 outdegreeG, indegreeG,
14 vertexGroupsG, emptyG,
17 -- For backwards compatability with the simpler version of Digraph
18 stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR,
20 -- No friendly interface yet, not used but exported to avoid warnings
22 components, undirected,
25 bcc, do_label, bicomps, collect
28 #include "HsVersions.h"
30 ------------------------------------------------------------------------------
31 -- A version of the graph algorithms described in:
33 -- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''
34 -- by David King and John Launchbury
36 -- Also included is some additional code for printing tree structures ...
37 ------------------------------------------------------------------------------
40 import Util ( sortLe )
42 import Maybes ( expectJust )
43 import MonadUtils ( allM )
46 import Control.Monad ( filterM, liftM, liftM2 )
47 import Control.Monad.ST
52 import Data.List ( (\\) )
56 %************************************************************************
58 %* Graphs and Graph Construction
60 %************************************************************************
62 Note [Nodes, keys, vertices]
63 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
64 * A 'node' is a big blob of client-stuff
66 * Each 'node' has a unique (client) 'key', but the latter
67 is in Ord and has fast comparison
69 * Digraph then maps each 'key' to a Vertex (Int) which is
70 arranged densely in 0.n
73 data Graph node = Graph {
74 gr_int_graph :: IntGraph,
75 gr_vertex_to_node :: Vertex -> node,
76 gr_node_to_vertex :: node -> Maybe Vertex
79 data Edge node = Edge node node
82 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
84 graphFromVerticesAndAdjacency
87 -> [(key, key)] -- First component is source vertex key,
88 -- second is target vertex key (thing depended on)
89 -- Unlike the other interface I insist they correspond to
90 -- actual vertices because the alternative hides bugs. I can't
91 -- do the same thing for the other one for backcompat reasons.
93 graphFromVerticesAndAdjacency [] _ = emptyGraph
94 graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor)
95 where key_extractor = snd
96 (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVertices vertices key_extractor
97 key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a,
98 expectJust "graphFromVerticesAndAdjacency" $ key_vertex b)
99 reduced_edges = map key_vertex_pair edges
100 graph = buildG bounds reduced_edges
102 graphFromEdgedVertices
104 => [(node, key, [key])] -- The graph; its ok for the
105 -- out-list to contain keys which arent
106 -- a vertex key, they are ignored
107 -> Graph (node, key, [key])
108 graphFromEdgedVertices [] = emptyGraph
109 graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor)
110 where key_extractor (_, k, _) = k
111 (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor
112 graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes]
114 reduceNodesIntoVertices
118 -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)])
119 reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
121 max_v = length nodes - 1
122 bounds = (0, max_v) :: (Vertex, Vertex)
124 sorted_nodes = let n1 `le` n2 = (key_extractor n1 `compare` key_extractor n2) /= GT
126 numbered_nodes = zipWith (,) [0..] sorted_nodes
128 key_map = array bounds [(i, key_extractor node) | (i, node) <- numbered_nodes]
129 vertex_map = array bounds numbered_nodes
131 --key_vertex :: key -> Maybe Vertex
132 -- returns Nothing for non-interesting vertices
133 key_vertex k = find 0 max_v
135 find a b | a > b = Nothing
136 | otherwise = let mid = (a + b) `div` 2
137 in case compare k (key_map ! mid) of
138 LT -> find a (mid - 1)
140 GT -> find (mid + 1) b
143 %************************************************************************
147 %************************************************************************
150 data SCC vertex = AcyclicSCC vertex
153 instance Functor SCC where
154 fmap f (AcyclicSCC v) = AcyclicSCC (f v)
155 fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)
157 flattenSCCs :: [SCC a] -> [a]
158 flattenSCCs = concatMap flattenSCC
160 flattenSCC :: SCC a -> [a]
161 flattenSCC (AcyclicSCC v) = [v]
162 flattenSCC (CyclicSCC vs) = vs
164 instance Outputable a => Outputable (SCC a) where
165 ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
166 ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
169 %************************************************************************
171 %* Strongly Connected Component wrappers for Graph
173 %************************************************************************
175 Note: the components are returned topologically sorted: later components
176 depend on earlier ones, but not vice versa i.e. later components only have
177 edges going from them to earlier ones.
180 stronglyConnCompG :: Graph node -> [SCC node]
181 stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn }) = map decode forest
183 forest = {-# SCC "Digraph.scc" #-} scc graph
184 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
185 | otherwise = AcyclicSCC (vertex_fn v)
186 decode other = CyclicSCC (dec other [])
187 where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
188 mentions_itself v = v `elem` (graph ! v)
191 -- The following two versions are provided for backwards compatability:
192 stronglyConnCompFromEdgedVertices
194 => [(node, key, [key])]
196 stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
197 where get_node (n, _, _) = n
199 -- The "R" interface is used when you expect to apply SCC to
200 -- the (some of) the result of SCC, so you dont want to lose the dependency info
201 stronglyConnCompFromEdgedVerticesR
203 => [(node, key, [key])]
204 -> [SCC (node, key, [key])]
205 stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices
208 %************************************************************************
210 %* Misc wrappers for Graph
212 %************************************************************************
215 topologicalSortG :: Graph node -> [node]
216 topologicalSortG graph = map (gr_vertex_to_node graph) result
217 where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
219 reachableG :: Graph node -> node -> [node]
220 reachableG graph from = map (gr_vertex_to_node graph) result
221 where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
222 result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) from_vertex
224 hasVertexG :: Graph node -> node -> Bool
225 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
227 verticesG :: Graph node -> [node]
228 verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
230 edgesG :: Graph node -> [Edge node]
231 edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
232 where v2n = gr_vertex_to_node graph
234 transposeG :: Graph node -> Graph node
235 transposeG graph = Graph (transpose (gr_int_graph graph)) (gr_vertex_to_node graph) (gr_node_to_vertex graph)
237 outdegreeG :: Graph node -> node -> Maybe Int
238 outdegreeG = degreeG outdegree
240 indegreeG :: Graph node -> node -> Maybe Int
241 indegreeG = degreeG indegree
243 degreeG :: (IntGraph -> Table Int) -> Graph node -> node -> Maybe Int
244 degreeG degree graph node = let table = degree (gr_int_graph graph)
245 in fmap ((!) table) $ gr_node_to_vertex graph node
247 vertexGroupsG :: Graph node -> [[node]]
248 vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result
249 where result = vertexGroups (gr_int_graph graph)
251 emptyG :: Graph node -> Bool
252 emptyG g = graphEmpty (gr_int_graph g)
254 componentsG :: Graph node -> [[node]]
255 componentsG graph = map (map (gr_vertex_to_node graph) . flattenTree) $ components (gr_int_graph graph)
258 %************************************************************************
262 %************************************************************************
266 instance Outputable node => Outputable (Graph node) where
268 hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
269 hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
272 instance Outputable node => Outputable (Edge node) where
273 ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
277 %************************************************************************
281 %************************************************************************
285 type Table a = Array Vertex a
286 type IntGraph = Table [Vertex]
287 type Bounds = (Vertex, Vertex)
288 type IntEdge = (Vertex, Vertex)
292 vertices :: IntGraph -> [Vertex]
295 edges :: IntGraph -> [IntEdge]
296 edges g = [ (v, w) | v <- vertices g, w <- g!v ]
298 mapT :: (Vertex -> a -> b) -> Table a -> Table b
299 mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ]
301 buildG :: Bounds -> [IntEdge] -> IntGraph
302 buildG bounds edges = accumArray (flip (:)) [] bounds edges
304 transpose :: IntGraph -> IntGraph
305 transpose g = buildG (bounds g) (reverseE g)
307 reverseE :: IntGraph -> [IntEdge]
308 reverseE g = [ (w, v) | (v, w) <- edges g ]
310 outdegree :: IntGraph -> Table Int
311 outdegree = mapT numEdges
312 where numEdges _ ws = length ws
314 indegree :: IntGraph -> Table Int
315 indegree = outdegree . transpose
317 graphEmpty :: IntGraph -> Bool
318 graphEmpty g = lo > hi
319 where (lo, hi) = bounds g
323 %************************************************************************
327 %************************************************************************
330 data Tree a = Node a (Forest a)
331 type Forest a = [Tree a]
333 mapTree :: (a -> b) -> (Tree a -> Tree b)
334 mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
336 flattenTree :: Tree a -> [a]
337 flattenTree (Node x ts) = x : concatMap flattenTree ts
341 instance Show a => Show (Tree a) where
342 showsPrec _ t s = showTree t ++ s
344 showTree :: Show a => Tree a -> String
345 showTree = drawTree . mapTree show
347 instance Show a => Show (Forest a) where
348 showsPrec _ f s = showForest f ++ s
350 showForest :: Show a => Forest a -> String
351 showForest = unlines . map showTree
353 drawTree :: Tree String -> String
354 drawTree = unlines . draw
356 draw :: Tree String -> [String]
357 draw (Node x ts) = grp this (space (length this)) (stLoop ts)
358 where this = s1 ++ x ++ " "
360 space n = replicate n ' '
363 stLoop [t] = grp s2 " " (draw t)
364 stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
367 rsLoop [t] = grp s5 " " (draw t)
368 rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
370 grp fst rst = zipWith (++) (fst:repeat rst)
372 [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
376 %************************************************************************
378 %* Depth first search
380 %************************************************************************
383 type Set s = STArray s Vertex Bool
385 mkEmpty :: Bounds -> ST s (Set s)
386 mkEmpty bnds = newArray bnds False
388 contains :: Set s -> Vertex -> ST s Bool
389 contains m v = readArray m v
391 include :: Set s -> Vertex -> ST s ()
392 include m v = writeArray m v True
396 dff :: IntGraph -> Forest Vertex
397 dff g = dfs g (vertices g)
399 dfs :: IntGraph -> [Vertex] -> Forest Vertex
400 dfs g vs = prune (bounds g) (map (generate g) vs)
402 generate :: IntGraph -> Vertex -> Tree Vertex
403 generate g v = Node v (map (generate g) (g!v))
405 prune :: Bounds -> Forest Vertex -> Forest Vertex
406 prune bnds ts = runST (mkEmpty bnds >>= \m ->
409 chop :: Set s -> Forest Vertex -> ST s (Forest Vertex)
410 chop _ [] = return []
411 chop m (Node v ts : us)
412 = contains m v >>= \visited ->
416 include m v >>= \_ ->
419 return (Node v as : bs)
423 %************************************************************************
427 %************************************************************************
429 ------------------------------------------------------------
430 -- Algorithm 1: depth first search numbering
431 ------------------------------------------------------------
434 preorder :: Tree a -> [a]
435 preorder (Node a ts) = a : preorderF ts
437 preorderF :: Forest a -> [a]
438 preorderF ts = concat (map preorder ts)
440 tabulate :: Bounds -> [Vertex] -> Table Int
441 tabulate bnds vs = array bnds (zip vs [1..])
443 preArr :: Bounds -> Forest Vertex -> Table Int
444 preArr bnds = tabulate bnds . preorderF
447 ------------------------------------------------------------
448 -- Algorithm 2: topological sorting
449 ------------------------------------------------------------
452 postorder :: Tree a -> [a] -> [a]
453 postorder (Node a ts) = postorderF ts . (a :)
455 postorderF :: Forest a -> [a] -> [a]
456 postorderF ts = foldr (.) id $ map postorder ts
458 postOrd :: IntGraph -> [Vertex]
459 postOrd g = postorderF (dff g) []
461 topSort :: IntGraph -> [Vertex]
462 topSort = reverse . postOrd
465 ------------------------------------------------------------
466 -- Algorithm 3: connected components
467 ------------------------------------------------------------
470 components :: IntGraph -> Forest Vertex
471 components = dff . undirected
473 undirected :: IntGraph -> IntGraph
474 undirected g = buildG (bounds g) (edges g ++ reverseE g)
477 ------------------------------------------------------------
478 -- Algorithm 4: strongly connected components
479 ------------------------------------------------------------
482 scc :: IntGraph -> Forest Vertex
483 scc g = dfs g (reverse (postOrd (transpose g)))
486 ------------------------------------------------------------
487 -- Algorithm 5: Classifying edges
488 ------------------------------------------------------------
491 back :: IntGraph -> Table Int -> IntGraph
492 back g post = mapT select g
493 where select v ws = [ w | w <- ws, post!v < post!w ]
495 cross :: IntGraph -> Table Int -> Table Int -> IntGraph
496 cross g pre post = mapT select g
497 where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
499 forward :: IntGraph -> IntGraph -> Table Int -> IntGraph
500 forward g tree pre = mapT select g
501 where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
504 ------------------------------------------------------------
505 -- Algorithm 6: Finding reachable vertices
506 ------------------------------------------------------------
509 reachable :: IntGraph -> Vertex -> [Vertex]
510 reachable g v = preorderF (dfs g [v])
512 path :: IntGraph -> Vertex -> Vertex -> Bool
513 path g v w = w `elem` (reachable g v)
516 ------------------------------------------------------------
517 -- Algorithm 7: Biconnected components
518 ------------------------------------------------------------
521 bcc :: IntGraph -> Forest [Vertex]
522 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
524 dnum = preArr (bounds g) forest
526 do_label :: IntGraph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
527 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
528 where us = map (do_label g dnum) ts
529 lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
530 ++ [lu | Node (_,_,lu) _ <- us])
532 bicomps :: Tree (Vertex, Int, Int) -> Forest [Vertex]
533 bicomps (Node (v,_,_) ts)
534 = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]
536 collect :: Tree (Vertex, Int, Int) -> (Int, Tree [Vertex])
537 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
538 where collected = map collect ts
539 vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv]
540 cs = concat [ if lw<dv then us else [Node (v:ws) us]
541 | (lw, Node ws us) <- collected ]
544 ------------------------------------------------------------
545 -- Algorithm 8: Total ordering on groups of vertices
546 ------------------------------------------------------------
548 The plan here is to extract a list of groups of elements of the graph
549 such that each group has no dependence except on nodes in previous
550 groups (i.e. in particular they may not depend on nodes in their own
551 group) and is maximal such group.
553 Clearly we cannot provide a solution for cyclic graphs.
555 We proceed by iteratively removing elements with no outgoing edges
556 and their associated edges from the graph.
558 This probably isn't very efficient and certainly isn't very clever.
562 vertexGroups :: IntGraph -> [[Vertex]]
563 vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices)
564 where next_vertices = noOutEdges g
566 noOutEdges :: IntGraph -> [Vertex]
567 noOutEdges g = [ v | v <- vertices g, null (g!v)]
569 vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]
570 vertexGroupsS provided g to_provide
573 all_provided <- allM (provided `contains`) (vertices g)
576 else error "vertexGroup: cyclic graph"
579 mapM_ (include provided) to_provide
580 ; to_provide' <- filterM (vertexReady provided g) (vertices g)
581 ; rest <- vertexGroupsS provided g to_provide'
582 ; return $ to_provide : rest
585 vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool
586 vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v))