1 %
2 % (c) The University of Glasgow 2006
3 %
5 \begin{code}
6 module Digraph(
9         SCC(..), flattenSCC, flattenSCCs,
10         stronglyConnCompG, topologicalSortG,
11         verticesG, edgesG, hasVertexG,
12         reachableG, transposeG,
13         outdegreeG, indegreeG,
14         vertexGroupsG, emptyG,
15         componentsG,
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
21         tabulate, preArr,
22         components, undirected,
23         back, cross, forward,
24         path,
25         bcc, do_label, bicomps, collect
26     ) where
28 #include "HsVersions.h"
30 ------------------------------------------------------------------------------
31 -- A version of the graph algorithms described in:
32 --
33 -- Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''
34 --   by David King and John Launchbury
35 --
36 -- Also included is some additional code for printing tree structures ...
37 ------------------------------------------------------------------------------
40 import Util        ( sortLe )
41 import Outputable
42 import Maybes      ( expectJust )
43 import MonadUtils  ( allM )
45 -- Extensions
46 import Control.Monad    ( filterM, liftM, liftM2 )
49 -- std interfaces
50 import Data.Maybe
51 import Data.Array
52 import Data.List   ( (\\) )
53 import Data.Array.ST
54 \end{code}
56 %************************************************************************
57 %*                                                                      *
58 %*      Graphs and Graph Construction
59 %*                                                                      *
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
72 \begin{code}
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
77   }
79 data Edge node = Edge node node
81 emptyGraph :: Graph a
82 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
85         :: Ord key
86         => [(node, key)]
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.
92         -> Graph (node, key)
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
103         :: Ord key
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
115         :: Ord key
116         => [node]
117         -> (node -> key)
118         -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)])
119 reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
120   where
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
125                       in sortLe le nodes
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
134       where
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)
139                                     EQ -> Just mid
140                                     GT -> find (mid + 1) b
141 \end{code}
143 %************************************************************************
144 %*                                                                      *
145 %*      SCC
146 %*                                                                      *
147 %************************************************************************
149 \begin{code}
150 data SCC vertex = AcyclicSCC vertex
151                 | CyclicSCC  [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)))
167 \end{code}
169 %************************************************************************
170 %*                                                                      *
171 %*      Strongly Connected Component wrappers for Graph
172 %*                                                                      *
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.
179 \begin{code}
180 stronglyConnCompG :: Graph node -> [SCC node]
181 stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn }) = map decode forest
182   where
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
193         :: Ord key
194         => [(node, key, [key])]
195         -> [SCC node]
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
202         :: Ord key
203         => [(node, key, [key])]
204         -> [SCC (node, key, [key])]
205 stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices
206 \end{code}
208 %************************************************************************
209 %*                                                                      *
210 %*      Misc wrappers for Graph
211 %*                                                                      *
212 %************************************************************************
214 \begin{code}
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) 256 \end{code} 258 %************************************************************************ 259 %* * 260 %* Showing Graphs 261 %* * 262 %************************************************************************ 264 \begin{code} 266 instance Outputable node => Outputable (Graph node) where 267 ppr graph = vcat [ 268 hang (text "Vertices:") 2 (vcat (map ppr$ verticesG graph)),
269                   hang (text "Edges:") 2 (vcat (map ppr $edgesG graph)) 270 ] 272 instance Outputable node => Outputable (Edge node) where 273 ppr (Edge from to) = ppr from <+> text "->" <+> ppr to 275 \end{code} 277 %************************************************************************ 278 %* * 279 %* IntGraphs 280 %* * 281 %************************************************************************ 283 \begin{code} 284 type Vertex = Int 285 type Table a = Array Vertex a 286 type IntGraph = Table [Vertex] 287 type Bounds = (Vertex, Vertex) 288 type IntEdge = (Vertex, Vertex) 289 \end{code} 291 \begin{code} 292 vertices :: IntGraph -> [Vertex] 293 vertices = indices 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 321 \end{code} 323 %************************************************************************ 324 %* * 325 %* Trees and forests 326 %* * 327 %************************************************************************ 329 \begin{code} 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 338 \end{code} 340 \begin{code} 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 ' ' 362 stLoop [] = [""] 363 stLoop [t] = grp s2 " " (draw t) 364 stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts 366 rsLoop [] = [] 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] = ["- ", "--", "-+", " |", " ", " +"] 373 \end{code} 376 %************************************************************************ 377 %* * 378 %* Depth first search 379 %* * 380 %************************************************************************ 382 \begin{code} 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 393 \end{code} 395 \begin{code} 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 -> 407 chop m ts) 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 -> 413 if visited then 414 chop m us 415 else 416 include m v >>= \_ -> 417 chop m ts >>= \as -> 418 chop m us >>= \bs -> 419 return (Node v as : bs) 420 \end{code} 423 %************************************************************************ 424 %* * 425 %* Algorithms 426 %* * 427 %************************************************************************ 429 ------------------------------------------------------------ 430 -- Algorithm 1: depth first search numbering 431 ------------------------------------------------------------ 433 \begin{code} 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 445 \end{code} 447 ------------------------------------------------------------ 448 -- Algorithm 2: topological sorting 449 ------------------------------------------------------------ 451 \begin{code} 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
463 \end{code}
465 ------------------------------------------------------------
466 -- Algorithm 3: connected components
467 ------------------------------------------------------------
469 \begin{code}
470 components   :: IntGraph -> Forest Vertex
471 components    = dff . undirected
473 undirected   :: IntGraph -> IntGraph
474 undirected g  = buildG (bounds g) (edges g ++ reverseE g)
475 \end{code}
477 ------------------------------------------------------------
478 -- Algorithm 4: strongly connected components
479 ------------------------------------------------------------
481 \begin{code}
482 scc  :: IntGraph -> Forest Vertex
483 scc g = dfs g (reverse (postOrd (transpose g)))
484 \end{code}
486 ------------------------------------------------------------
487 -- Algorithm 5: Classifying edges
488 ------------------------------------------------------------
490 \begin{code}
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
502 \end{code}
504 ------------------------------------------------------------
505 -- Algorithm 6: Finding reachable vertices
506 ------------------------------------------------------------
508 \begin{code}
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)
514 \end{code}
516 ------------------------------------------------------------
517 -- Algorithm 7: Biconnected components
518 ------------------------------------------------------------
520 \begin{code}
521 bcc :: IntGraph -> Forest [Vertex]
522 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
523  where forest = dff g
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 ]
542 \end{code}
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.
560 \begin{code}
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
571   = if null to_provide
572     then do {
573           all_provided <- allM (provided contains) (vertices g)
574         ; if all_provided
575           then return []
576           else error "vertexGroup: cyclic graph"
577         }
578     else do {
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 583 } 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))
587 \end{code}