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 )
45 import Control.Monad ( filterM, liftM, liftM2 )
46 import Control.Monad.ST
51 import Data.List ( (\\) )
53 #if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604
56 import Data.Array.ST hiding ( indices, bounds )
60 %************************************************************************
62 %* Graphs and Graph Construction
64 %************************************************************************
66 Note [Nodes, keys, vertices]
67 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
68 * A 'node' is a big blob of client-stuff
70 * Each 'node' has a unique (client) 'key', but the latter
71 is in Ord and has fast comparison
73 * Digraph then maps each 'key' to a Vertex (Int) which is
74 arranged densely in 0.n
77 data Graph node = Graph {
78 gr_int_graph :: IntGraph,
79 gr_vertex_to_node :: Vertex -> node,
80 gr_node_to_vertex :: node -> Maybe Vertex
83 data Edge node = Edge node node
86 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
88 graphFromVerticesAndAdjacency
91 -> [(key, key)] -- First component is source vertex key,
92 -- second is target vertex key (thing depended on)
93 -- Unlike the other interface I insist they correspond to
94 -- actual vertices because the alternative hides bugs. I can't
95 -- do the same thing for the other one for backcompat reasons.
97 graphFromVerticesAndAdjacency [] _ = emptyGraph
98 graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor)
99 where key_extractor = snd
100 (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVertices vertices key_extractor
101 key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a,
102 expectJust "graphFromVerticesAndAdjacency" $ key_vertex b)
103 reduced_edges = map key_vertex_pair edges
104 graph = buildG bounds reduced_edges
106 graphFromEdgedVertices
108 => [(node, key, [key])] -- The graph; its ok for the
109 -- out-list to contain keys which arent
110 -- a vertex key, they are ignored
111 -> Graph (node, key, [key])
112 graphFromEdgedVertices [] = emptyGraph
113 graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor)
114 where key_extractor (_, k, _) = k
115 (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor
116 graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes]
118 reduceNodesIntoVertices
122 -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)])
123 reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
125 max_v = length nodes - 1
126 bounds = (0, max_v) :: (Vertex, Vertex)
128 sorted_nodes = let n1 `le` n2 = (key_extractor n1 `compare` key_extractor n2) /= GT
130 numbered_nodes = zipWith (,) [0..] sorted_nodes
132 key_map = array bounds [(i, key_extractor node) | (i, node) <- numbered_nodes]
133 vertex_map = array bounds numbered_nodes
135 --key_vertex :: key -> Maybe Vertex
136 -- returns Nothing for non-interesting vertices
137 key_vertex k = find 0 max_v
139 find a b | a > b = Nothing
140 | otherwise = let mid = (a + b) `div` 2
141 in case compare k (key_map ! mid) of
142 LT -> find a (mid - 1)
144 GT -> find (mid + 1) b
147 %************************************************************************
151 %************************************************************************
154 data SCC vertex = AcyclicSCC vertex
157 instance Functor SCC where
158 fmap f (AcyclicSCC v) = AcyclicSCC (f v)
159 fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)
161 flattenSCCs :: [SCC a] -> [a]
162 flattenSCCs = concatMap flattenSCC
164 flattenSCC :: SCC a -> [a]
165 flattenSCC (AcyclicSCC v) = [v]
166 flattenSCC (CyclicSCC vs) = vs
168 instance Outputable a => Outputable (SCC a) where
169 ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
170 ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
173 %************************************************************************
175 %* Strongly Connected Component wrappers for Graph
177 %************************************************************************
179 Note: the components are returned topologically sorted: later components
180 depend on earlier ones, but not vice versa i.e. later components only have
181 edges going from them to earlier ones.
184 stronglyConnCompG :: Graph node -> [SCC node]
185 stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn }) = map decode forest
187 forest = {-# SCC "Digraph.scc" #-} scc graph
188 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
189 | otherwise = AcyclicSCC (vertex_fn v)
190 decode other = CyclicSCC (dec other [])
191 where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
192 mentions_itself v = v `elem` (graph ! v)
195 -- The following two versions are provided for backwards compatability:
196 stronglyConnCompFromEdgedVertices
198 => [(node, key, [key])]
200 stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
201 where get_node (n, _, _) = n
203 -- The "R" interface is used when you expect to apply SCC to
204 -- the (some of) the result of SCC, so you dont want to lose the dependency info
205 stronglyConnCompFromEdgedVerticesR
207 => [(node, key, [key])]
208 -> [SCC (node, key, [key])]
209 stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices
212 %************************************************************************
214 %* Misc wrappers for Graph
216 %************************************************************************
219 topologicalSortG :: Graph node -> [node]
220 topologicalSortG graph = map (gr_vertex_to_node graph) result
221 where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
223 reachableG :: Graph node -> node -> [node]
224 reachableG graph from = map (gr_vertex_to_node graph) result
225 where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
226 result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) from_vertex
228 hasVertexG :: Graph node -> node -> Bool
229 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
231 verticesG :: Graph node -> [node]
232 verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
234 edgesG :: Graph node -> [Edge node]
235 edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
236 where v2n = gr_vertex_to_node graph
238 transposeG :: Graph node -> Graph node
239 transposeG graph = Graph (transpose (gr_int_graph graph)) (gr_vertex_to_node graph) (gr_node_to_vertex graph)
241 outdegreeG :: Graph node -> node -> Maybe Int
242 outdegreeG = degreeG outdegree
244 indegreeG :: Graph node -> node -> Maybe Int
245 indegreeG = degreeG indegree
247 degreeG :: (IntGraph -> Table Int) -> Graph node -> node -> Maybe Int
248 degreeG degree graph node = let table = degree (gr_int_graph graph)
249 in fmap ((!) table) $ gr_node_to_vertex graph node
251 vertexGroupsG :: Graph node -> [[node]]
252 vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result
253 where result = vertexGroups (gr_int_graph graph)
255 emptyG :: Graph node -> Bool
256 emptyG g = graphEmpty (gr_int_graph g)
258 componentsG :: Graph node -> [[node]]
259 componentsG graph = map (map (gr_vertex_to_node graph) . flattenTree) $ components (gr_int_graph graph)
262 %************************************************************************
266 %************************************************************************
270 instance Outputable node => Outputable (Graph node) where
272 hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
273 hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
276 instance Outputable node => Outputable (Edge node) where
277 ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
281 %************************************************************************
285 %************************************************************************
289 type Table a = Array Vertex a
290 type IntGraph = Table [Vertex]
291 type Bounds = (Vertex, Vertex)
292 type IntEdge = (Vertex, Vertex)
296 vertices :: IntGraph -> [Vertex]
299 edges :: IntGraph -> [IntEdge]
300 edges g = [ (v, w) | v <- vertices g, w <- g!v ]
302 mapT :: (Vertex -> a -> b) -> Table a -> Table b
303 mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ]
305 buildG :: Bounds -> [IntEdge] -> IntGraph
306 buildG bounds edges = accumArray (flip (:)) [] bounds edges
308 transpose :: IntGraph -> IntGraph
309 transpose g = buildG (bounds g) (reverseE g)
311 reverseE :: IntGraph -> [IntEdge]
312 reverseE g = [ (w, v) | (v, w) <- edges g ]
314 outdegree :: IntGraph -> Table Int
315 outdegree = mapT numEdges
316 where numEdges _ ws = length ws
318 indegree :: IntGraph -> Table Int
319 indegree = outdegree . transpose
321 graphEmpty :: IntGraph -> Bool
322 graphEmpty g = lo > hi
323 where (lo, hi) = bounds g
327 %************************************************************************
331 %************************************************************************
334 data Tree a = Node a (Forest a)
335 type Forest a = [Tree a]
337 mapTree :: (a -> b) -> (Tree a -> Tree b)
338 mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
340 flattenTree :: Tree a -> [a]
341 flattenTree (Node x ts) = x : concatMap flattenTree ts
345 instance Show a => Show (Tree a) where
346 showsPrec _ t s = showTree t ++ s
348 showTree :: Show a => Tree a -> String
349 showTree = drawTree . mapTree show
351 instance Show a => Show (Forest a) where
352 showsPrec _ f s = showForest f ++ s
354 showForest :: Show a => Forest a -> String
355 showForest = unlines . map showTree
357 drawTree :: Tree String -> String
358 drawTree = unlines . draw
360 draw :: Tree String -> [String]
361 draw (Node x ts) = grp this (space (length this)) (stLoop ts)
362 where this = s1 ++ x ++ " "
364 space n = replicate n ' '
367 stLoop [t] = grp s2 " " (draw t)
368 stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
371 rsLoop [t] = grp s5 " " (draw t)
372 rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
374 grp fst rst = zipWith (++) (fst:repeat rst)
376 [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
380 %************************************************************************
382 %* Depth first search
384 %************************************************************************
387 type Set s = STArray s Vertex Bool
389 mkEmpty :: Bounds -> ST s (Set s)
390 mkEmpty bnds = newArray bnds False
392 contains :: Set s -> Vertex -> ST s Bool
393 contains m v = readArray m v
395 include :: Set s -> Vertex -> ST s ()
396 include m v = writeArray m v True
400 dff :: IntGraph -> Forest Vertex
401 dff g = dfs g (vertices g)
403 dfs :: IntGraph -> [Vertex] -> Forest Vertex
404 dfs g vs = prune (bounds g) (map (generate g) vs)
406 generate :: IntGraph -> Vertex -> Tree Vertex
407 generate g v = Node v (map (generate g) (g!v))
409 prune :: Bounds -> Forest Vertex -> Forest Vertex
410 prune bnds ts = runST (mkEmpty bnds >>= \m ->
413 chop :: Set s -> Forest Vertex -> ST s (Forest Vertex)
414 chop _ [] = return []
415 chop m (Node v ts : us)
416 = contains m v >>= \visited ->
420 include m v >>= \_ ->
423 return (Node v as : bs)
427 %************************************************************************
431 %************************************************************************
433 ------------------------------------------------------------
434 -- Algorithm 1: depth first search numbering
435 ------------------------------------------------------------
438 preorder :: Tree a -> [a]
439 preorder (Node a ts) = a : preorderF ts
441 preorderF :: Forest a -> [a]
442 preorderF ts = concat (map preorder ts)
444 tabulate :: Bounds -> [Vertex] -> Table Int
445 tabulate bnds vs = array bnds (zip vs [1..])
447 preArr :: Bounds -> Forest Vertex -> Table Int
448 preArr bnds = tabulate bnds . preorderF
451 ------------------------------------------------------------
452 -- Algorithm 2: topological sorting
453 ------------------------------------------------------------
456 postorder :: Tree a -> [a] -> [a]
457 postorder (Node a ts) = postorderF ts . (a :)
459 postorderF :: Forest a -> [a] -> [a]
460 postorderF ts = foldr (.) id $ map postorder ts
462 postOrd :: IntGraph -> [Vertex]
463 postOrd g = postorderF (dff g) []
465 topSort :: IntGraph -> [Vertex]
466 topSort = reverse . postOrd
469 ------------------------------------------------------------
470 -- Algorithm 3: connected components
471 ------------------------------------------------------------
474 components :: IntGraph -> Forest Vertex
475 components = dff . undirected
477 undirected :: IntGraph -> IntGraph
478 undirected g = buildG (bounds g) (edges g ++ reverseE g)
481 ------------------------------------------------------------
482 -- Algorithm 4: strongly connected components
483 ------------------------------------------------------------
486 scc :: IntGraph -> Forest Vertex
487 scc g = dfs g (reverse (postOrd (transpose g)))
490 ------------------------------------------------------------
491 -- Algorithm 5: Classifying edges
492 ------------------------------------------------------------
495 back :: IntGraph -> Table Int -> IntGraph
496 back g post = mapT select g
497 where select v ws = [ w | w <- ws, post!v < post!w ]
499 cross :: IntGraph -> Table Int -> Table Int -> IntGraph
500 cross g pre post = mapT select g
501 where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
503 forward :: IntGraph -> IntGraph -> Table Int -> IntGraph
504 forward g tree pre = mapT select g
505 where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
508 ------------------------------------------------------------
509 -- Algorithm 6: Finding reachable vertices
510 ------------------------------------------------------------
513 reachable :: IntGraph -> Vertex -> [Vertex]
514 reachable g v = preorderF (dfs g [v])
516 path :: IntGraph -> Vertex -> Vertex -> Bool
517 path g v w = w `elem` (reachable g v)
520 ------------------------------------------------------------
521 -- Algorithm 7: Biconnected components
522 ------------------------------------------------------------
525 bcc :: IntGraph -> Forest [Vertex]
526 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
528 dnum = preArr (bounds g) forest
530 do_label :: IntGraph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
531 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
532 where us = map (do_label g dnum) ts
533 lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
534 ++ [lu | Node (_,_,lu) _ <- us])
536 bicomps :: Tree (Vertex, Int, Int) -> Forest [Vertex]
537 bicomps (Node (v,_,_) ts)
538 = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]
540 collect :: Tree (Vertex, Int, Int) -> (Int, Tree [Vertex])
541 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
542 where collected = map collect ts
543 vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv]
544 cs = concat [ if lw<dv then us else [Node (v:ws) us]
545 | (lw, Node ws us) <- collected ]
548 ------------------------------------------------------------
549 -- Algorithm 8: Total ordering on groups of vertices
550 ------------------------------------------------------------
552 The plan here is to extract a list of groups of elements of the graph
553 such that each group has no dependence except on nodes in previous
554 groups (i.e. in particular they may not depend on nodes in their own
555 group) and is maximal such group.
557 Clearly we cannot provide a solution for cyclic graphs.
559 We proceed by iteratively removing elements with no outgoing edges
560 and their associated edges from the graph.
562 This probably isn't very efficient and certainly isn't very clever.
566 vertexGroups :: IntGraph -> [[Vertex]]
567 vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices)
568 where next_vertices = noOutEdges g
570 noOutEdges :: IntGraph -> [Vertex]
571 noOutEdges g = [ v | v <- vertices g, null (g!v)]
573 vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]
574 vertexGroupsS provided g to_provide
577 all_provided <- allM (provided `contains`) (vertices g)
580 else error "vertexGroup: cyclic graph"
583 mapM_ (include provided) to_provide
584 ; to_provide' <- filterM (vertexReady provided g) (vertices g)
585 ; rest <- vertexGroupsS provided g to_provide'
586 ; return $ to_provide : rest
589 vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool
590 vertexReady provided g v = liftM2 (&&) (liftM not $ provided `contains` v) (allM (provided `contains`) (g!v))
592 allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
593 allM _ [] = return True
594 allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False)