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 ( (\\) )
54 #if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604
57 import Data.Array.ST hiding ( indices, bounds )
61 %************************************************************************
63 %* Graphs and Graph Construction
65 %************************************************************************
67 Note [Nodes, keys, vertices]
68 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
69 * A 'node' is a big blob of client-stuff
71 * Each 'node' has a unique (client) 'key', but the latter
72 is in Ord and has fast comparison
74 * Digraph then maps each 'key' to a Vertex (Int) which is
75 arranged densely in 0.n
78 data Graph node = Graph {
79 gr_int_graph :: IntGraph,
80 gr_vertex_to_node :: Vertex -> node,
81 gr_node_to_vertex :: node -> Maybe Vertex
84 data Edge node = Edge node node
87 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
89 graphFromVerticesAndAdjacency
92 -> [(key, key)] -- First component is source vertex key,
93 -- second is target vertex key (thing depended on)
94 -- Unlike the other interface I insist they correspond to
95 -- actual vertices because the alternative hides bugs. I can't
96 -- do the same thing for the other one for backcompat reasons.
98 graphFromVerticesAndAdjacency [] _ = emptyGraph
99 graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor)
100 where key_extractor = snd
101 (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVertices vertices key_extractor
102 key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a,
103 expectJust "graphFromVerticesAndAdjacency" $ key_vertex b)
104 reduced_edges = map key_vertex_pair edges
105 graph = buildG bounds reduced_edges
107 graphFromEdgedVertices
109 => [(node, key, [key])] -- The graph; its ok for the
110 -- out-list to contain keys which arent
111 -- a vertex key, they are ignored
112 -> Graph (node, key, [key])
113 graphFromEdgedVertices [] = emptyGraph
114 graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor)
115 where key_extractor (_, k, _) = k
116 (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor
117 graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes]
119 reduceNodesIntoVertices
123 -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)])
124 reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
126 max_v = length nodes - 1
127 bounds = (0, max_v) :: (Vertex, Vertex)
129 sorted_nodes = let n1 `le` n2 = (key_extractor n1 `compare` key_extractor n2) /= GT
131 numbered_nodes = zipWith (,) [0..] sorted_nodes
133 key_map = array bounds [(i, key_extractor node) | (i, node) <- numbered_nodes]
134 vertex_map = array bounds numbered_nodes
136 --key_vertex :: key -> Maybe Vertex
137 -- returns Nothing for non-interesting vertices
138 key_vertex k = find 0 max_v
140 find a b | a > b = Nothing
141 | otherwise = let mid = (a + b) `div` 2
142 in case compare k (key_map ! mid) of
143 LT -> find a (mid - 1)
145 GT -> find (mid + 1) b
148 %************************************************************************
152 %************************************************************************
155 data SCC vertex = AcyclicSCC vertex
158 instance Functor SCC where
159 fmap f (AcyclicSCC v) = AcyclicSCC (f v)
160 fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)
162 flattenSCCs :: [SCC a] -> [a]
163 flattenSCCs = concatMap flattenSCC
165 flattenSCC :: SCC a -> [a]
166 flattenSCC (AcyclicSCC v) = [v]
167 flattenSCC (CyclicSCC vs) = vs
169 instance Outputable a => Outputable (SCC a) where
170 ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
171 ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
174 %************************************************************************
176 %* Strongly Connected Component wrappers for Graph
178 %************************************************************************
180 Note: the components are returned topologically sorted: later components
181 depend on earlier ones, but not vice versa i.e. later components only have
182 edges going from them to earlier ones.
185 stronglyConnCompG :: Graph node -> [SCC node]
186 stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn }) = map decode forest
188 forest = {-# SCC "Digraph.scc" #-} scc graph
189 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
190 | otherwise = AcyclicSCC (vertex_fn v)
191 decode other = CyclicSCC (dec other [])
192 where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
193 mentions_itself v = v `elem` (graph ! v)
196 -- The following two versions are provided for backwards compatability:
197 stronglyConnCompFromEdgedVertices
199 => [(node, key, [key])]
201 stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
202 where get_node (n, _, _) = n
204 -- The "R" interface is used when you expect to apply SCC to
205 -- the (some of) the result of SCC, so you dont want to lose the dependency info
206 stronglyConnCompFromEdgedVerticesR
208 => [(node, key, [key])]
209 -> [SCC (node, key, [key])]
210 stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices
213 %************************************************************************
215 %* Misc wrappers for Graph
217 %************************************************************************
220 topologicalSortG :: Graph node -> [node]
221 topologicalSortG graph = map (gr_vertex_to_node graph) result
222 where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
224 reachableG :: Graph node -> node -> [node]
225 reachableG graph from = map (gr_vertex_to_node graph) result
226 where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
227 result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) from_vertex
229 hasVertexG :: Graph node -> node -> Bool
230 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
232 verticesG :: Graph node -> [node]
233 verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
235 edgesG :: Graph node -> [Edge node]
236 edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
237 where v2n = gr_vertex_to_node graph
239 transposeG :: Graph node -> Graph node
240 transposeG graph = Graph (transpose (gr_int_graph graph)) (gr_vertex_to_node graph) (gr_node_to_vertex graph)
242 outdegreeG :: Graph node -> node -> Maybe Int
243 outdegreeG = degreeG outdegree
245 indegreeG :: Graph node -> node -> Maybe Int
246 indegreeG = degreeG indegree
248 degreeG :: (IntGraph -> Table Int) -> Graph node -> node -> Maybe Int
249 degreeG degree graph node = let table = degree (gr_int_graph graph)
250 in fmap ((!) table) $ gr_node_to_vertex graph node
252 vertexGroupsG :: Graph node -> [[node]]
253 vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result
254 where result = vertexGroups (gr_int_graph graph)
256 emptyG :: Graph node -> Bool
257 emptyG g = graphEmpty (gr_int_graph g)
259 componentsG :: Graph node -> [[node]]
260 componentsG graph = map (map (gr_vertex_to_node graph) . flattenTree) $ components (gr_int_graph graph)
263 %************************************************************************
267 %************************************************************************
271 instance Outputable node => Outputable (Graph node) where
273 hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
274 hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
277 instance Outputable node => Outputable (Edge node) where
278 ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
282 %************************************************************************
286 %************************************************************************
290 type Table a = Array Vertex a
291 type IntGraph = Table [Vertex]
292 type Bounds = (Vertex, Vertex)
293 type IntEdge = (Vertex, Vertex)
297 vertices :: IntGraph -> [Vertex]
300 edges :: IntGraph -> [IntEdge]
301 edges g = [ (v, w) | v <- vertices g, w <- g!v ]
303 mapT :: (Vertex -> a -> b) -> Table a -> Table b
304 mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ]
306 buildG :: Bounds -> [IntEdge] -> IntGraph
307 buildG bounds edges = accumArray (flip (:)) [] bounds edges
309 transpose :: IntGraph -> IntGraph
310 transpose g = buildG (bounds g) (reverseE g)
312 reverseE :: IntGraph -> [IntEdge]
313 reverseE g = [ (w, v) | (v, w) <- edges g ]
315 outdegree :: IntGraph -> Table Int
316 outdegree = mapT numEdges
317 where numEdges _ ws = length ws
319 indegree :: IntGraph -> Table Int
320 indegree = outdegree . transpose
322 graphEmpty :: IntGraph -> Bool
323 graphEmpty g = lo > hi
324 where (lo, hi) = bounds g
328 %************************************************************************
332 %************************************************************************
335 data Tree a = Node a (Forest a)
336 type Forest a = [Tree a]
338 mapTree :: (a -> b) -> (Tree a -> Tree b)
339 mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
341 flattenTree :: Tree a -> [a]
342 flattenTree (Node x ts) = x : concatMap flattenTree ts
346 instance Show a => Show (Tree a) where
347 showsPrec _ t s = showTree t ++ s
349 showTree :: Show a => Tree a -> String
350 showTree = drawTree . mapTree show
352 instance Show a => Show (Forest a) where
353 showsPrec _ f s = showForest f ++ s
355 showForest :: Show a => Forest a -> String
356 showForest = unlines . map showTree
358 drawTree :: Tree String -> String
359 drawTree = unlines . draw
361 draw :: Tree String -> [String]
362 draw (Node x ts) = grp this (space (length this)) (stLoop ts)
363 where this = s1 ++ x ++ " "
365 space n = replicate n ' '
368 stLoop [t] = grp s2 " " (draw t)
369 stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
372 rsLoop [t] = grp s5 " " (draw t)
373 rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
375 grp fst rst = zipWith (++) (fst:repeat rst)
377 [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
381 %************************************************************************
383 %* Depth first search
385 %************************************************************************
388 type Set s = STArray s Vertex Bool
390 mkEmpty :: Bounds -> ST s (Set s)
391 mkEmpty bnds = newArray bnds False
393 contains :: Set s -> Vertex -> ST s Bool
394 contains m v = readArray m v
396 include :: Set s -> Vertex -> ST s ()
397 include m v = writeArray m v True
401 dff :: IntGraph -> Forest Vertex
402 dff g = dfs g (vertices g)
404 dfs :: IntGraph -> [Vertex] -> Forest Vertex
405 dfs g vs = prune (bounds g) (map (generate g) vs)
407 generate :: IntGraph -> Vertex -> Tree Vertex
408 generate g v = Node v (map (generate g) (g!v))
410 prune :: Bounds -> Forest Vertex -> Forest Vertex
411 prune bnds ts = runST (mkEmpty bnds >>= \m ->
414 chop :: Set s -> Forest Vertex -> ST s (Forest Vertex)
415 chop _ [] = return []
416 chop m (Node v ts : us)
417 = contains m v >>= \visited ->
421 include m v >>= \_ ->
424 return (Node v as : bs)
428 %************************************************************************
432 %************************************************************************
434 ------------------------------------------------------------
435 -- Algorithm 1: depth first search numbering
436 ------------------------------------------------------------
439 preorder :: Tree a -> [a]
440 preorder (Node a ts) = a : preorderF ts
442 preorderF :: Forest a -> [a]
443 preorderF ts = concat (map preorder ts)
445 tabulate :: Bounds -> [Vertex] -> Table Int
446 tabulate bnds vs = array bnds (zip vs [1..])
448 preArr :: Bounds -> Forest Vertex -> Table Int
449 preArr bnds = tabulate bnds . preorderF
452 ------------------------------------------------------------
453 -- Algorithm 2: topological sorting
454 ------------------------------------------------------------
457 postorder :: Tree a -> [a] -> [a]
458 postorder (Node a ts) = postorderF ts . (a :)
460 postorderF :: Forest a -> [a] -> [a]
461 postorderF ts = foldr (.) id $ map postorder ts
463 postOrd :: IntGraph -> [Vertex]
464 postOrd g = postorderF (dff g) []
466 topSort :: IntGraph -> [Vertex]
467 topSort = reverse . postOrd
470 ------------------------------------------------------------
471 -- Algorithm 3: connected components
472 ------------------------------------------------------------
475 components :: IntGraph -> Forest Vertex
476 components = dff . undirected
478 undirected :: IntGraph -> IntGraph
479 undirected g = buildG (bounds g) (edges g ++ reverseE g)
482 ------------------------------------------------------------
483 -- Algorithm 4: strongly connected components
484 ------------------------------------------------------------
487 scc :: IntGraph -> Forest Vertex
488 scc g = dfs g (reverse (postOrd (transpose g)))
491 ------------------------------------------------------------
492 -- Algorithm 5: Classifying edges
493 ------------------------------------------------------------
496 back :: IntGraph -> Table Int -> IntGraph
497 back g post = mapT select g
498 where select v ws = [ w | w <- ws, post!v < post!w ]
500 cross :: IntGraph -> Table Int -> Table Int -> IntGraph
501 cross g pre post = mapT select g
502 where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
504 forward :: IntGraph -> IntGraph -> Table Int -> IntGraph
505 forward g tree pre = mapT select g
506 where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
509 ------------------------------------------------------------
510 -- Algorithm 6: Finding reachable vertices
511 ------------------------------------------------------------
514 reachable :: IntGraph -> Vertex -> [Vertex]
515 reachable g v = preorderF (dfs g [v])
517 path :: IntGraph -> Vertex -> Vertex -> Bool
518 path g v w = w `elem` (reachable g v)
521 ------------------------------------------------------------
522 -- Algorithm 7: Biconnected components
523 ------------------------------------------------------------
526 bcc :: IntGraph -> Forest [Vertex]
527 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
529 dnum = preArr (bounds g) forest
531 do_label :: IntGraph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
532 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
533 where us = map (do_label g dnum) ts
534 lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
535 ++ [lu | Node (_,_,lu) _ <- us])
537 bicomps :: Tree (Vertex, Int, Int) -> Forest [Vertex]
538 bicomps (Node (v,_,_) ts)
539 = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]
541 collect :: Tree (Vertex, Int, Int) -> (Int, Tree [Vertex])
542 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
543 where collected = map collect ts
544 vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv]
545 cs = concat [ if lw<dv then us else [Node (v:ws) us]
546 | (lw, Node ws us) <- collected ]
549 ------------------------------------------------------------
550 -- Algorithm 8: Total ordering on groups of vertices
551 ------------------------------------------------------------
553 The plan here is to extract a list of groups of elements of the graph
554 such that each group has no dependence except on nodes in previous
555 groups (i.e. in particular they may not depend on nodes in their own
556 group) and is maximal such group.
558 Clearly we cannot provide a solution for cyclic graphs.
560 We proceed by iteratively removing elements with no outgoing edges
561 and their associated edges from the graph.
563 This probably isn't very efficient and certainly isn't very clever.
567 vertexGroups :: IntGraph -> [[Vertex]]
568 vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices)
569 where next_vertices = noOutEdges g
571 noOutEdges :: IntGraph -> [Vertex]
572 noOutEdges g = [ v | v <- vertices g, null (g!v)]
574 vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]
575 vertexGroupsS provided g to_provide
578 all_provided <- allM (provided `contains`) (vertices g)
581 else error "vertexGroup: cyclic graph"
584 mapM_ (include provided) to_provide
585 ; to_provide' <- filterM (vertexReady provided g) (vertices g)
586 ; rest <- vertexGroupsS provided g to_provide'
587 ; return $ to_provide : rest
590 vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool
591 vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v))