1 -----------------------------------------------------------------------------
4 -- Copyright : (c) The University of Glasgow 2002
5 -- License : BSD-style (see the file libraries/base/LICENSE)
7 -- Maintainer : libraries@haskell.org
8 -- Stability : experimental
9 -- Portability : non-portable (requires non-portable module ST)
11 -- A version of the graph algorithms described in:
13 -- /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,
14 -- by David King and John Launchbury.
16 -----------------------------------------------------------------------------
20 -- * External interface
22 -- At present the only one with a "nice" external interface
23 stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
27 Graph, Table, Bounds, Edge, Vertex,
31 graphFromEdges, buildG, transposeG,
34 -- ** Graph properties
46 -- back, cross, forward,
54 import Control.Monad.ST
55 import Data.Array.ST (STArray, newArray, readArray, writeArray)
56 import Data.Tree (Tree(Node), Forest)
63 -------------------------------------------------------------------------
67 -------------------------------------------------------------------------
69 -- | Strongly connected component.
70 data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not
72 | CyclicSCC [vertex] -- ^ A maximal set of mutually
73 -- reachable vertices.
75 -- | The vertices of a list of strongly connected components.
76 flattenSCCs :: [SCC a] -> [a]
77 flattenSCCs = concatMap flattenSCC
79 -- | The vertices of a strongly connected component.
80 flattenSCC :: SCC vertex -> [vertex]
81 flattenSCC (AcyclicSCC v) = [v]
82 flattenSCC (CyclicSCC vs) = vs
84 -- | The strongly connected components of a directed graph, topologically
88 => [(node, key, [key])]
89 -- ^ The graph: a list of nodes uniquely identified by keys,
90 -- with a list of keys of nodes this node has edges to.
91 -- The out-list may contain keys that don't correspond to
92 -- nodes of the graph; such edges are ignored.
95 stronglyConnComp edges0
96 = map get_node (stronglyConnCompR edges0)
98 get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
99 get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]
101 -- | The strongly connected components of a directed graph, topologically
102 -- sorted. The function is the same as 'stronglyConnComp', except that
103 -- all the information about each node retained.
104 -- This interface is used when you expect to apply 'SCC' to
105 -- (some of) the result of 'SCC', so you don't want to lose the
106 -- dependency information.
109 => [(node, key, [key])]
110 -- ^ The graph: a list of nodes uniquely identified by keys,
111 -- with a list of keys of nodes this node has edges to.
112 -- The out-list may contain keys that don't correspond to
113 -- nodes of the graph; such edges are ignored.
114 -> [SCC (node, key, [key])] -- ^ Topologically sorted
116 stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
117 stronglyConnCompR edges0
120 (graph, vertex_fn) = graphFromEdges edges0
122 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
123 | otherwise = AcyclicSCC (vertex_fn v)
124 decode other = CyclicSCC (dec other [])
126 dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
127 mentions_itself v = v `elem` (graph ! v)
129 -------------------------------------------------------------------------
133 -------------------------------------------------------------------------
135 -- | Abstract representation of vertices.
137 -- | Table indexed by a contiguous set of vertices.
138 type Table a = Array Vertex a
139 -- | Adjacency list representation of a graph, mapping each vertex to its
140 -- list of successors.
141 type Graph = Table [Vertex]
142 -- | The bounds of a 'Table'.
143 type Bounds = (Vertex, Vertex)
144 -- | An edge from the first vertex to the second.
145 type Edge = (Vertex, Vertex)
147 -- | All vertices of a graph.
148 vertices :: Graph -> [Vertex]
151 -- | All edges of a graph.
152 edges :: Graph -> [Edge]
153 edges g = [ (v, w) | v <- vertices g, w <- g!v ]
155 mapT :: (Vertex -> a -> b) -> Table a -> Table b
156 mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
158 -- | Build a graph from a list of edges.
159 buildG :: Bounds -> [Edge] -> Graph
160 buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0
162 -- | The graph obtained by reversing all edges.
163 transposeG :: Graph -> Graph
164 transposeG g = buildG (bounds g) (reverseE g)
166 reverseE :: Graph -> [Edge]
167 reverseE g = [ (w, v) | (v, w) <- edges g ]
169 -- | A table of the count of edges from each node.
170 outdegree :: Graph -> Table Int
171 outdegree = mapT numEdges
172 where numEdges _ ws = length ws
174 -- | A table of the count of edges into each node.
175 indegree :: Graph -> Table Int
176 indegree = outdegree . transposeG
178 -- | Build a graph from a list of nodes uniquely identified by keys,
179 -- with a list of keys of nodes this node should have edges to.
180 -- The out-list may contain keys that don't correspond to
181 -- nodes of the graph; they are ignored.
184 => [(node, key, [key])]
185 -> (Graph, Vertex -> (node, key, [key]))
186 graphFromEdges edges0
187 = (graph, \v -> vertex_map ! v)
189 max_v = length edges0 - 1
190 bounds0 = (0,max_v) :: (Vertex, Vertex)
191 sorted_edges = sortBy lt edges0
192 edges1 = zipWith (,) [0..] sorted_edges
194 graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
195 key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1]
196 vertex_map = array bounds0 edges1
198 (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
200 -- key_vertex :: key -> Maybe Vertex
201 -- returns Nothing for non-interesting vertices
202 key_vertex k = findVertex 0 max_v
204 findVertex a b | a > b
206 findVertex a b = case compare k (key_map ! mid) of
207 LT -> findVertex a (mid-1)
209 GT -> findVertex (mid+1) b
211 mid = (a + b) `div` 2
213 -------------------------------------------------------------------------
215 -- Depth first search
217 -------------------------------------------------------------------------
219 type Set s = STArray s Vertex Bool
221 mkEmpty :: Bounds -> ST s (Set s)
222 mkEmpty bnds = newArray bnds False
224 contains :: Set s -> Vertex -> ST s Bool
225 contains m v = readArray m v
227 include :: Set s -> Vertex -> ST s ()
228 include m v = writeArray m v True
230 -- | A spanning forest of the graph, obtained from a depth-first search of
231 -- the graph starting from each vertex in an unspecified order.
232 dff :: Graph -> Forest Vertex
233 dff g = dfs g (vertices g)
235 -- | A spanning forest of the part of the graph reachable from the listed
236 -- vertices, obtained from a depth-first search of the graph starting at
237 -- each of the listed vertices in order.
238 dfs :: Graph -> [Vertex] -> Forest Vertex
239 dfs g vs = prune (bounds g) (map (generate g) vs)
241 generate :: Graph -> Vertex -> Tree Vertex
242 generate g v = Node v (map (generate g) (g!v))
244 prune :: Bounds -> Forest Vertex -> Forest Vertex
245 prune bnds ts = runST (mkEmpty bnds >>= \m ->
248 chop :: Set s -> Forest Vertex -> ST s (Forest Vertex)
249 chop _ [] = return []
250 chop m (Node v ts : us)
251 = contains m v >>= \visited ->
255 include m v >>= \_ ->
258 return (Node v as : bs)
260 -------------------------------------------------------------------------
264 -------------------------------------------------------------------------
266 ------------------------------------------------------------
267 -- Algorithm 1: depth first search numbering
268 ------------------------------------------------------------
270 preorder :: Tree a -> [a]
271 preorder (Node a ts) = a : preorderF ts
273 preorderF :: Forest a -> [a]
274 preorderF ts = concat (map preorder ts)
276 tabulate :: Bounds -> [Vertex] -> Table Int
277 tabulate bnds vs = array bnds (zipWith (,) vs [1..])
279 preArr :: Bounds -> Forest Vertex -> Table Int
280 preArr bnds = tabulate bnds . preorderF
282 ------------------------------------------------------------
283 -- Algorithm 2: topological sorting
284 ------------------------------------------------------------
286 postorder :: Tree a -> [a]
287 postorder (Node a ts) = postorderF ts ++ [a]
289 postorderF :: Forest a -> [a]
290 postorderF ts = concat (map postorder ts)
292 postOrd :: Graph -> [Vertex]
293 postOrd = postorderF . dff
295 -- | A topological sort of the graph.
296 -- The order is partially specified by the condition that a vertex /i/
297 -- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.
298 topSort :: Graph -> [Vertex]
299 topSort = reverse . postOrd
301 ------------------------------------------------------------
302 -- Algorithm 3: connected components
303 ------------------------------------------------------------
305 -- | The connected components of a graph.
306 -- Two vertices are connected if there is a path between them, traversing
307 -- edges in either direction.
308 components :: Graph -> Forest Vertex
309 components = dff . undirected
311 undirected :: Graph -> Graph
312 undirected g = buildG (bounds g) (edges g ++ reverseE g)
314 -- Algorithm 4: strongly connected components
316 -- | The strongly connected components of a graph.
317 scc :: Graph -> Forest Vertex
318 scc g = dfs g (reverse (postOrd (transposeG g)))
320 ------------------------------------------------------------
321 -- Algorithm 5: Classifying edges
322 ------------------------------------------------------------
324 back :: Graph -> Table Int -> Graph
325 back g post = mapT select g
326 where select v ws = [ w | w <- ws, post!v < post!w ]
328 cross :: Graph -> Table Int -> Table Int -> Graph
329 cross g pre post = mapT select g
330 where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
332 forward :: Graph -> Graph -> Table Int -> Graph
333 forward g tree pre = mapT select g
334 where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
336 ------------------------------------------------------------
337 -- Algorithm 6: Finding reachable vertices
338 ------------------------------------------------------------
340 -- | A list of vertices reachable from a given vertex.
341 reachable :: Graph -> Vertex -> [Vertex]
342 reachable g v = preorderF (dfs g [v])
344 -- | Is the second vertex reachable from the first?
345 path :: Graph -> Vertex -> Vertex -> Bool
346 path g v w = w `elem` (reachable g v)
348 ------------------------------------------------------------
349 -- Algorithm 7: Biconnected components
350 ------------------------------------------------------------
352 -- | The biconnected components of a graph.
353 -- An undirected graph is biconnected if the deletion of any vertex
354 -- leaves it connected.
355 bcc :: Graph -> Forest [Vertex]
356 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
358 dnum = preArr (bounds g) forest
360 do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
361 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
362 where us = map (do_label g dnum) ts
363 lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
364 ++ [lu | Node (u,du,lu) xs <- us])
366 bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
367 bicomps (Node (v,_,_) ts)
368 = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
370 collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
371 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
372 where collected = map collect ts
373 vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
374 cs = concat [ if lw<dv then us else [Node (v:ws) us]
375 | (lw, Node ws us) <- collected ]