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 : portable
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, graphFromEdges', buildG, transposeG,
34 -- ** Graph properties
46 -- tree, back, cross, forward,
53 #if __GLASGOW_HASKELL__
54 # define USE_ST_MONAD 1
59 import Control.Monad.ST
60 import Data.Array.ST (STArray, newArray, readArray, writeArray)
62 import Data.IntSet (IntSet)
63 import qualified Data.IntSet as Set
65 import Data.Tree (Tree(Node), Forest)
76 -------------------------------------------------------------------------
80 -------------------------------------------------------------------------
82 -- | Strongly connected component.
83 data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not
85 | CyclicSCC [vertex] -- ^ A maximal set of mutually
86 -- reachable vertices.
88 -- | The vertices of a list of strongly connected components.
89 flattenSCCs :: [SCC a] -> [a]
90 flattenSCCs = concatMap flattenSCC
92 -- | The vertices of a strongly connected component.
93 flattenSCC :: SCC vertex -> [vertex]
94 flattenSCC (AcyclicSCC v) = [v]
95 flattenSCC (CyclicSCC vs) = vs
97 -- | The strongly connected components of a directed graph, topologically
101 => [(node, key, [key])]
102 -- ^ The graph: a list of nodes uniquely identified by keys,
103 -- with a list of keys of nodes this node has edges to.
104 -- The out-list may contain keys that don't correspond to
105 -- nodes of the graph; such edges are ignored.
108 stronglyConnComp edges0
109 = map get_node (stronglyConnCompR edges0)
111 get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
112 get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]
114 -- | The strongly connected components of a directed graph, topologically
115 -- sorted. The function is the same as 'stronglyConnComp', except that
116 -- all the information about each node retained.
117 -- This interface is used when you expect to apply 'SCC' to
118 -- (some of) the result of 'SCC', so you don't want to lose the
119 -- dependency information.
122 => [(node, key, [key])]
123 -- ^ The graph: a list of nodes uniquely identified by keys,
124 -- with a list of keys of nodes this node has edges to.
125 -- The out-list may contain keys that don't correspond to
126 -- nodes of the graph; such edges are ignored.
127 -> [SCC (node, key, [key])] -- ^ Topologically sorted
129 stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
130 stronglyConnCompR edges0
133 (graph, vertex_fn,_) = graphFromEdges edges0
135 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
136 | otherwise = AcyclicSCC (vertex_fn v)
137 decode other = CyclicSCC (dec other [])
139 dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
140 mentions_itself v = v `elem` (graph ! v)
142 -------------------------------------------------------------------------
146 -------------------------------------------------------------------------
148 -- | Abstract representation of vertices.
150 -- | Table indexed by a contiguous set of vertices.
151 type Table a = Array Vertex a
152 -- | Adjacency list representation of a graph, mapping each vertex to its
153 -- list of successors.
154 type Graph = Table [Vertex]
155 -- | The bounds of a 'Table'.
156 type Bounds = (Vertex, Vertex)
157 -- | An edge from the first vertex to the second.
158 type Edge = (Vertex, Vertex)
160 -- | All vertices of a graph.
161 vertices :: Graph -> [Vertex]
164 -- | All edges of a graph.
165 edges :: Graph -> [Edge]
166 edges g = [ (v, w) | v <- vertices g, w <- g!v ]
168 mapT :: (Vertex -> a -> b) -> Table a -> Table b
169 mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
171 -- | Build a graph from a list of edges.
172 buildG :: Bounds -> [Edge] -> Graph
173 buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0
175 -- | The graph obtained by reversing all edges.
176 transposeG :: Graph -> Graph
177 transposeG g = buildG (bounds g) (reverseE g)
179 reverseE :: Graph -> [Edge]
180 reverseE g = [ (w, v) | (v, w) <- edges g ]
182 -- | A table of the count of edges from each node.
183 outdegree :: Graph -> Table Int
184 outdegree = mapT numEdges
185 where numEdges _ ws = length ws
187 -- | A table of the count of edges into each node.
188 indegree :: Graph -> Table Int
189 indegree = outdegree . transposeG
191 -- | Identical to 'graphFromEdges', except that the return value
192 -- does not include the function which maps keys to vertices. This
193 -- version of 'graphFromEdges' is for backwards compatibility.
196 => [(node, key, [key])]
197 -> (Graph, Vertex -> (node, key, [key]))
198 graphFromEdges' x = (a,b) where
199 (a,b,_) = graphFromEdges x
201 -- | Build a graph from a list of nodes uniquely identified by keys,
202 -- with a list of keys of nodes this node should have edges to.
203 -- The out-list may contain keys that don't correspond to
204 -- nodes of the graph; they are ignored.
207 => [(node, key, [key])]
208 -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
209 graphFromEdges edges0
210 = (graph, \v -> vertex_map ! v, key_vertex)
212 max_v = length edges0 - 1
213 bounds0 = (0,max_v) :: (Vertex, Vertex)
214 sorted_edges = sortBy lt edges0
215 edges1 = zipWith (,) [0..] sorted_edges
217 graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
218 key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1]
219 vertex_map = array bounds0 edges1
221 (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
223 -- key_vertex :: key -> Maybe Vertex
224 -- returns Nothing for non-interesting vertices
225 key_vertex k = findVertex 0 max_v
227 findVertex a b | a > b
229 findVertex a b = case compare k (key_map ! mid) of
230 LT -> findVertex a (mid-1)
232 GT -> findVertex (mid+1) b
234 mid = (a + b) `div` 2
236 -------------------------------------------------------------------------
238 -- Depth first search
240 -------------------------------------------------------------------------
242 -- | A spanning forest of the graph, obtained from a depth-first search of
243 -- the graph starting from each vertex in an unspecified order.
244 dff :: Graph -> Forest Vertex
245 dff g = dfs g (vertices g)
247 -- | A spanning forest of the part of the graph reachable from the listed
248 -- vertices, obtained from a depth-first search of the graph starting at
249 -- each of the listed vertices in order.
250 dfs :: Graph -> [Vertex] -> Forest Vertex
251 dfs g vs = prune (bounds g) (map (generate g) vs)
253 generate :: Graph -> Vertex -> Tree Vertex
254 generate g v = Node v (map (generate g) (g!v))
256 prune :: Bounds -> Forest Vertex -> Forest Vertex
257 prune bnds ts = run bnds (chop ts)
259 chop :: Forest Vertex -> SetM s (Forest Vertex)
261 chop (Node v ts : us)
263 visited <- contains v
270 return (Node v as : bs)
272 -- A monad holding a set of vertices visited so far.
275 -- Use the ST monad if available, for constant-time primitives.
277 newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a }
279 instance Monad (SetM s) where
280 return x = SetM $ const (return x)
281 SetM v >>= f = SetM $ \ s -> do { x <- v s; runSetM (f x) s }
283 run :: Bounds -> (forall s. SetM s a) -> a
284 run bnds act = runST (newArray bnds False >>= runSetM act)
286 contains :: Vertex -> SetM s Bool
287 contains v = SetM $ \ m -> readArray m v
289 include :: Vertex -> SetM s ()
290 include v = SetM $ \ m -> writeArray m v True
292 #else /* !USE_ST_MONAD */
294 -- Portable implementation using IntSet.
296 newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }
298 instance Monad (SetM s) where
299 return x = SetM $ \ s -> (x, s)
300 SetM v >>= f = SetM $ \ s -> case v s of (x, s') -> runSetM (f x) s'
302 run :: Bounds -> SetM s a -> a
303 run _ act = fst (runSetM act Set.empty)
305 contains :: Vertex -> SetM s Bool
306 contains v = SetM $ \ m -> (Set.member v m, m)
308 include :: Vertex -> SetM s ()
309 include v = SetM $ \ m -> ((), Set.insert v m)
311 #endif /* !USE_ST_MONAD */
313 -------------------------------------------------------------------------
317 -------------------------------------------------------------------------
319 ------------------------------------------------------------
320 -- Algorithm 1: depth first search numbering
321 ------------------------------------------------------------
323 preorder :: Tree a -> [a]
324 preorder (Node a ts) = a : preorderF ts
326 preorderF :: Forest a -> [a]
327 preorderF ts = concat (map preorder ts)
329 tabulate :: Bounds -> [Vertex] -> Table Int
330 tabulate bnds vs = array bnds (zipWith (,) vs [1..])
332 preArr :: Bounds -> Forest Vertex -> Table Int
333 preArr bnds = tabulate bnds . preorderF
335 ------------------------------------------------------------
336 -- Algorithm 2: topological sorting
337 ------------------------------------------------------------
339 postorder :: Tree a -> [a]
340 postorder (Node a ts) = postorderF ts ++ [a]
342 postorderF :: Forest a -> [a]
343 postorderF ts = concat (map postorder ts)
345 postOrd :: Graph -> [Vertex]
346 postOrd = postorderF . dff
348 -- | A topological sort of the graph.
349 -- The order is partially specified by the condition that a vertex /i/
350 -- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.
351 topSort :: Graph -> [Vertex]
352 topSort = reverse . postOrd
354 ------------------------------------------------------------
355 -- Algorithm 3: connected components
356 ------------------------------------------------------------
358 -- | The connected components of a graph.
359 -- Two vertices are connected if there is a path between them, traversing
360 -- edges in either direction.
361 components :: Graph -> Forest Vertex
362 components = dff . undirected
364 undirected :: Graph -> Graph
365 undirected g = buildG (bounds g) (edges g ++ reverseE g)
367 -- Algorithm 4: strongly connected components
369 -- | The strongly connected components of a graph.
370 scc :: Graph -> Forest Vertex
371 scc g = dfs g (reverse (postOrd (transposeG g)))
373 ------------------------------------------------------------
374 -- Algorithm 5: Classifying edges
375 ------------------------------------------------------------
377 tree :: Bounds -> Forest Vertex -> Graph
378 tree bnds ts = buildG bnds (concat (map flat ts))
379 where flat (Node v ts) = [ (v, w) | Node w _us <- ts ] ++ concat (map flat ts)
381 back :: Graph -> Table Int -> Graph
382 back g post = mapT select g
383 where select v ws = [ w | w <- ws, post!v < post!w ]
385 cross :: Graph -> Table Int -> Table Int -> Graph
386 cross g pre post = mapT select g
387 where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
389 forward :: Graph -> Graph -> Table Int -> Graph
390 forward g tree pre = mapT select g
391 where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
393 ------------------------------------------------------------
394 -- Algorithm 6: Finding reachable vertices
395 ------------------------------------------------------------
397 -- | A list of vertices reachable from a given vertex.
398 reachable :: Graph -> Vertex -> [Vertex]
399 reachable g v = preorderF (dfs g [v])
401 -- | Is the second vertex reachable from the first?
402 path :: Graph -> Vertex -> Vertex -> Bool
403 path g v w = w `elem` (reachable g v)
405 ------------------------------------------------------------
406 -- Algorithm 7: Biconnected components
407 ------------------------------------------------------------
409 -- | The biconnected components of a graph.
410 -- An undirected graph is biconnected if the deletion of any vertex
411 -- leaves it connected.
412 bcc :: Graph -> Forest [Vertex]
413 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
415 dnum = preArr (bounds g) forest
417 do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
418 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
419 where us = map (do_label g dnum) ts
420 lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
421 ++ [lu | Node (u,du,lu) xs <- us])
423 bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
424 bicomps (Node (v,_,_) ts)
425 = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
427 collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
428 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
429 where collected = map collect ts
430 vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
431 cs = concat [ if lw<dv then us else [Node (v:ws) us]
432 | (lw, Node ws us) <- collected ]