2c90c1e41ec36b64bd8997d2fb43b74250ca39b1
1 -- (c) The University of Glasgow 2006
3 {-# LANGUAGE CPP, ScopedTypeVariables #-}
5 module Digraph(
6 Graph, graphFromEdgedVertices,
8 SCC(..), Node, flattenSCC, flattenSCCs,
9 stronglyConnCompG,
10 topologicalSortG, dfsTopSortG,
11 verticesG, edgesG, hasVertexG,
12 reachableG, reachablesG, transposeG,
13 outdegreeG, indegreeG,
14 vertexGroupsG, emptyG,
15 componentsG,
17 findCycle,
19 -- For backwards compatability with the simpler version of Digraph
20 stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR,
21 ) where
23 #include "HsVersions.h"
25 ------------------------------------------------------------------------------
26 -- A version of the graph algorithms described in:
27 --
28 -- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''
29 -- by David King and John Launchbury
30 --
31 -- Also included is some additional code for printing tree structures ...
32 --
33 -- If you ever find yourself in need of algorithms for classifying edges,
34 -- or finding connected/biconnected components, consult the history; Sigbjorn
35 -- Finne contributed some implementations in 1997, although we've since
36 -- removed them since they were not used anywhere in GHC.
37 ------------------------------------------------------------------------------
40 import Util ( minWith, count )
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 hiding (transpose)
53 import Data.Array.ST
54 import qualified Data.Map as Map
55 import qualified Data.Set as Set
57 import qualified Data.Graph as G
58 import Data.Graph hiding (Graph, Edge, transposeG, reachable)
59 import Data.Tree
61 {-
62 ************************************************************************
63 * *
64 * Graphs and Graph Construction
65 * *
66 ************************************************************************
68 Note [Nodes, keys, vertices]
69 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
70 * A 'node' is a big blob of client-stuff
72 * Each 'node' has a unique (client) 'key', but the latter
73 is in Ord and has fast comparison
75 * Digraph then maps each 'key' to a Vertex (Int) which is
76 arranged densely in 0.n
77 -}
79 data Graph node = Graph {
80 gr_int_graph :: IntGraph,
81 gr_vertex_to_node :: Vertex -> node,
82 gr_node_to_vertex :: node -> Maybe Vertex
83 }
85 data Edge node = Edge node node
88 -- The payload is user data, just carried around in this module
89 -- The keys are ordered
90 -- The [key] are the dependencies of the node;
91 -- it's ok to have extra keys in the dependencies that
92 -- are not the key of any Node in the graph
94 emptyGraph :: Graph a
95 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
97 graphFromEdgedVertices
98 :: Ord key -- We only use Ord for efficiency,
99 -- it doesn't effect the result, so
100 -- it can be safely used with Unique's.
101 => [Node key payload] -- The graph; its ok for the
102 -- out-list to contain keys which arent
103 -- a vertex key, they are ignored
104 -> Graph (Node key payload)
105 graphFromEdgedVertices [] = emptyGraph
106 graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor)
107 where key_extractor (_, k, _) = k
108 (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor
109 graph = array bounds [ (v, sort \$ mapMaybe key_vertex ks)
110 | (v, (_, _, ks)) <- numbered_nodes]
111 -- We normalize outgoing edges by sorting on node order, so
112 -- that the result doesn't depend on the order of the edges
115 reduceNodesIntoVertices
116 :: Ord key
117 => [node]
118 -> (node -> key)
119 -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Vertex, node)])
120 reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes)
121 where
122 max_v = length nodes - 1
123 bounds = (0, max_v) :: (Vertex, Vertex)
125 -- Keep the order intact to make the result depend on input order
126 -- instead of key order
127 numbered_nodes = zip [0..] nodes
128 vertex_map = array bounds numbered_nodes
130 key_map = Map.fromList
131 [ (key_extractor node, v) | (v, node) <- numbered_nodes ]
132 key_vertex k = Map.lookup k key_map
134 {-
135 ************************************************************************
136 * *
137 * SCC
138 * *
139 ************************************************************************
140 -}
143 = (Node key payload, -- Tip of the path
144 [payload]) -- Rest of the path;
145 -- [a,b,c] means c depends on b, b depends on a
147 -- | Find a reasonably short cycle a->b->c->a, in a strongly
148 -- connected component. The input nodes are presumed to be
149 -- a SCC, so you can start anywhere.
150 findCycle :: forall payload key. Ord key
151 => [Node key payload] -- The nodes. The dependencies can
152 -- contain extra keys, which are ignored
153 -> Maybe [payload] -- A cycle, starting with node
154 -- so each depends on the next
155 findCycle graph
156 = go Set.empty (new_work root_deps []) []
157 where
158 env :: Map.Map key (Node key payload)
159 env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ]
161 -- Find the node with fewest dependencies among the SCC modules
162 -- This is just a heuristic to find some plausible root module
163 root :: Node key payload
164 root = fst (minWith snd [ (node, count (`Map.member` env) deps)
165 | node@(_,_,deps) <- graph ])
169 -- 'go' implements Dijkstra's algorithm, more or less
170 go :: Set.Set key -- Visited
171 -> [WorkItem key payload] -- Work list, items length n
172 -> [WorkItem key payload] -- Work list, items length n+1
173 -> Maybe [payload] -- Returned cycle
174 -- Invariant: in a call (go visited ps qs),
175 -- visited = union (map tail (ps ++ qs))
177 go _ [] [] = Nothing -- No cycles
178 go visited [] qs = go visited qs []
179 go visited (((payload,key,deps), path) : ps) qs
180 | key == root_key = Just (root_payload : reverse path)
181 | key `Set.member` visited = go visited ps qs
182 | key `Map.notMember` env = go visited ps qs
183 | otherwise = go (Set.insert key visited)
184 ps (new_qs ++ qs)
185 where
186 new_qs = new_work deps (payload : path)
189 new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
191 {-
192 ************************************************************************
193 * *
194 * Strongly Connected Component wrappers for Graph
195 * *
196 ************************************************************************
198 Note: the components are returned topologically sorted: later components
199 depend on earlier ones, but not vice versa i.e. later components only have
200 edges going from them to earlier ones.
201 -}
203 stronglyConnCompG :: Graph node -> [SCC node]
204 stronglyConnCompG graph = decodeSccs graph forest
205 where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)
207 decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
208 decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
209 = map decode forest
210 where
211 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
212 | otherwise = AcyclicSCC (vertex_fn v)
213 decode other = CyclicSCC (dec other [])
214 where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
215 mentions_itself v = v `elem` (graph ! v)
218 -- The following two versions are provided for backwards compatability:
219 stronglyConnCompFromEdgedVertices
220 :: Ord key
223 stronglyConnCompFromEdgedVertices
224 = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR
225 where get_node (n, _, _) = n
227 -- The "R" interface is used when you expect to apply SCC to
228 -- (some of) the result of SCC, so you dont want to lose the dependency info
229 stronglyConnCompFromEdgedVerticesR
230 :: Ord key
232 -> [SCC (Node key payload)]
233 stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices
235 {-
236 ************************************************************************
237 * *
238 * Misc wrappers for Graph
239 * *
240 ************************************************************************
241 -}
243 topologicalSortG :: Graph node -> [node]
244 topologicalSortG graph = map (gr_vertex_to_node graph) result
245 where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
247 dfsTopSortG :: Graph node -> [[node]]
248 dfsTopSortG graph =
249 map (map (gr_vertex_to_node graph) . flatten) \$ dfs g (topSort g)
250 where
251 g = gr_int_graph graph
253 reachableG :: Graph node -> node -> [node]
254 reachableG graph from = map (gr_vertex_to_node graph) result
255 where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
256 result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]
258 reachablesG :: Graph node -> [node] -> [node]
259 reachablesG graph froms = map (gr_vertex_to_node graph) result
260 where result = {-# SCC "Digraph.reachable" #-}
261 reachable (gr_int_graph graph) vs
262 vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
264 hasVertexG :: Graph node -> node -> Bool
265 hasVertexG graph node = isJust \$ gr_node_to_vertex graph node
267 verticesG :: Graph node -> [node]
268 verticesG graph = map (gr_vertex_to_node graph) \$ vertices (gr_int_graph graph)
270 edgesG :: Graph node -> [Edge node]
271 edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) \$ edges (gr_int_graph graph)
272 where v2n = gr_vertex_to_node graph
274 transposeG :: Graph node -> Graph node
275 transposeG graph = Graph (G.transposeG (gr_int_graph graph))
276 (gr_vertex_to_node graph)
277 (gr_node_to_vertex graph)
279 outdegreeG :: Graph node -> node -> Maybe Int
280 outdegreeG = degreeG outdegree
282 indegreeG :: Graph node -> node -> Maybe Int
283 indegreeG = degreeG indegree
285 degreeG :: (G.Graph -> Table Int) -> Graph node -> node -> Maybe Int
286 degreeG degree graph node = let table = degree (gr_int_graph graph)
287 in fmap ((!) table) \$ gr_node_to_vertex graph node
289 vertexGroupsG :: Graph node -> [[node]]
290 vertexGroupsG graph = map (map (gr_vertex_to_node graph)) result
291 where result = vertexGroups (gr_int_graph graph)
293 emptyG :: Graph node -> Bool
294 emptyG g = graphEmpty (gr_int_graph g)
296 componentsG :: Graph node -> [[node]]
297 componentsG graph = map (map (gr_vertex_to_node graph) . flatten)
298 \$ components (gr_int_graph graph)
300 {-
301 ************************************************************************
302 * *
303 * Showing Graphs
304 * *
305 ************************************************************************
306 -}
308 instance Outputable node => Outputable (Graph node) where
309 ppr graph = vcat [
310 hang (text "Vertices:") 2 (vcat (map ppr \$ verticesG graph)),
311 hang (text "Edges:") 2 (vcat (map ppr \$ edgesG graph))
312 ]
314 instance Outputable node => Outputable (Edge node) where
315 ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
317 graphEmpty :: G.Graph -> Bool
318 graphEmpty g = lo > hi
319 where (lo, hi) = bounds g
321 {-
322 ************************************************************************
323 * *
324 * IntGraphs
325 * *
326 ************************************************************************
327 -}
329 type IntGraph = G.Graph
331 {-
332 ------------------------------------------------------------
333 -- Depth first search numbering
334 ------------------------------------------------------------
335 -}
337 -- Data.Tree has flatten for Tree, but nothing for Forest
338 preorderF :: Forest a -> [a]
339 preorderF ts = concat (map flatten ts)
341 {-
342 ------------------------------------------------------------
343 -- Finding reachable vertices
344 ------------------------------------------------------------
345 -}
347 -- This generalizes reachable which was found in Data.Graph
348 reachable :: IntGraph -> [Vertex] -> [Vertex]
349 reachable g vs = preorderF (dfs g vs)
351 {-
352 ------------------------------------------------------------
353 -- Total ordering on groups of vertices
354 ------------------------------------------------------------
356 The plan here is to extract a list of groups of elements of the graph
357 such that each group has no dependence except on nodes in previous
358 groups (i.e. in particular they may not depend on nodes in their own
359 group) and is maximal such group.
361 Clearly we cannot provide a solution for cyclic graphs.
363 We proceed by iteratively removing elements with no outgoing edges
364 and their associated edges from the graph.
366 This probably isn't very efficient and certainly isn't very clever.
367 -}
369 type Set s = STArray s Vertex Bool
371 mkEmpty :: Bounds -> ST s (Set s)
372 mkEmpty bnds = newArray bnds False
374 contains :: Set s -> Vertex -> ST s Bool
375 contains m v = readArray m v
377 include :: Set s -> Vertex -> ST s ()
378 include m v = writeArray m v True
380 vertexGroups :: IntGraph -> [[Vertex]]
381 vertexGroups g = runST (mkEmpty (bounds g) >>= \provided -> vertexGroupsS provided g next_vertices)
382 where next_vertices = noOutEdges g
384 noOutEdges :: IntGraph -> [Vertex]
385 noOutEdges g = [ v | v <- vertices g, null (g!v)]
387 vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]]
388 vertexGroupsS provided g to_provide
389 = if null to_provide
390 then do {
391 all_provided <- allM (provided `contains`) (vertices g)
392 ; if all_provided
393 then return []
394 else error "vertexGroup: cyclic graph"
395 }
396 else do {
397 mapM_ (include provided) to_provide
398 ; to_provide' <- filterM (vertexReady provided g) (vertices g)
399 ; rest <- vertexGroupsS provided g to_provide'
400 ; return \$ to_provide : rest
401 }
403 vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool
404 vertexReady provided g v = liftM2 (&&) (liftM not \$ provided `contains` v) (allM (provided `contains`) (g!v))