82609801a0822b98ea2f0c7f05df3ca78ed2b9d2
[packages/containers.git] / Data / Graph.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE DeriveDataTypeable #-}
5 {-# LANGUAGE DeriveGeneric #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 # if __GLASGOW_HASKELL__ >= 710
8 {-# LANGUAGE Safe #-}
9 # else
10 {-# LANGUAGE Trustworthy #-}
11 # endif
12 #endif
13
14 #include "containers.h"
15
16 -----------------------------------------------------------------------------
17 -- |
18 -- Module : Data.Graph
19 -- Copyright : (c) The University of Glasgow 2002
20 -- License : BSD-style (see the file libraries/base/LICENSE)
21 --
22 -- Maintainer : libraries@haskell.org
23 -- Portability : portable
24 --
25 -- = Finite Graphs
26 --
27 -- The @'Graph'@ type is an adjacency list representation of a finite, directed
28 -- graph with vertices of type @Int@.
29 --
30 -- The @'SCC'@ type represents a
31 -- <https://en.wikipedia.org/wiki/Strongly_connected_component strongly-connected component>
32 -- of a graph.
33 --
34 -- == Implementation
35 --
36 -- The implementation is based on
37 --
38 -- * /Structuring Depth-First Search Algorithms in Haskell/,
39 -- by David King and John Launchbury, <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.52.6526>
40 --
41 -----------------------------------------------------------------------------
42
43 module Data.Graph (
44
45 -- * Graphs
46 Graph
47 , Bounds
48 , Edge
49 , Vertex
50 , Table
51
52 -- ** Graph Construction
53 , graphFromEdges
54 , graphFromEdges'
55 , buildG
56
57 -- ** Graph Properties
58 , vertices
59 , edges
60 , outdegree
61 , indegree
62
63 -- ** Graph Transformations
64 , transposeG
65
66 -- ** Graph Algorithms
67 , dfs
68 , dff
69 , topSort
70 , components
71 , scc
72 , bcc
73 , reachable
74 , path
75
76
77 -- * Strongly Connected Components
78 , SCC(..)
79
80 -- ** Construction
81 , stronglyConnComp
82 , stronglyConnCompR
83
84 -- ** Conversion
85 , flattenSCC
86 , flattenSCCs
87
88 -- * Trees
89 , module Data.Tree
90
91 ) where
92
93 #if USE_ST_MONAD
94 import Control.Monad.ST
95 import Data.Array.ST.Safe (newArray, readArray, writeArray)
96 # if USE_UNBOXED_ARRAYS
97 import Data.Array.ST.Safe (STUArray)
98 # else
99 import Data.Array.ST.Safe (STArray)
100 # endif
101 #else
102 import Data.IntSet (IntSet)
103 import qualified Data.IntSet as Set
104 #endif
105 import Data.Tree (Tree(Node), Forest)
106
107 -- std interfaces
108 import Control.Applicative
109 #if !MIN_VERSION_base(4,8,0)
110 import qualified Data.Foldable as F
111 import Data.Traversable
112 #else
113 import Data.Foldable as F
114 #endif
115 import Control.DeepSeq (NFData(rnf))
116 import Data.Maybe
117 import Data.Array
118 #if USE_UNBOXED_ARRAYS
119 import qualified Data.Array.Unboxed as UA
120 import Data.Array.Unboxed ( UArray )
121 #else
122 import qualified Data.Array as UA
123 #endif
124 import Data.List
125 #if MIN_VERSION_base(4,9,0)
126 import Data.Functor.Classes
127 #endif
128 #if (!MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)
129 import Data.Semigroup (Semigroup (..))
130 #endif
131 #ifdef __GLASGOW_HASKELL__
132 import GHC.Generics (Generic, Generic1)
133 import Data.Data (Data)
134 import Data.Typeable
135 #endif
136
137 -- Make sure we don't use Integer by mistake.
138 default ()
139
140 -------------------------------------------------------------------------
141 -- -
142 -- Strongly Connected Components
143 -- -
144 -------------------------------------------------------------------------
145
146 -- | Strongly connected component.
147 data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not
148 -- in any cycle.
149 | CyclicSCC [vertex] -- ^ A maximal set of mutually
150 -- reachable vertices.
151 #if __GLASGOW_HASKELL__ >= 802
152 deriving ( Eq -- ^ @since 0.5.9
153 , Show -- ^ @since 0.5.9
154 , Read -- ^ @since 0.5.9
155 )
156 #else
157 deriving (Eq, Show, Read)
158 #endif
159
160 INSTANCE_TYPEABLE1(SCC)
161
162 #ifdef __GLASGOW_HASKELL__
163 -- | @since 0.5.9
164 deriving instance Data vertex => Data (SCC vertex)
165
166 -- | @since 0.5.9
167 deriving instance Generic1 SCC
168
169 -- | @since 0.5.9
170 deriving instance Generic (SCC vertex)
171 #endif
172
173 #if MIN_VERSION_base(4,9,0)
174 -- | @since 0.5.9
175 instance Eq1 SCC where
176 liftEq eq (AcyclicSCC v1) (AcyclicSCC v2) = eq v1 v2
177 liftEq eq (CyclicSCC vs1) (CyclicSCC vs2) = liftEq eq vs1 vs2
178 liftEq _ _ _ = False
179 -- | @since 0.5.9
180 instance Show1 SCC where
181 liftShowsPrec sp _sl d (AcyclicSCC v) = showsUnaryWith sp "AcyclicSCC" d v
182 liftShowsPrec _sp sl d (CyclicSCC vs) = showsUnaryWith (const sl) "CyclicSCC" d vs
183 -- | @since 0.5.9
184 instance Read1 SCC where
185 liftReadsPrec rp rl = readsData $
186 readsUnaryWith rp "AcyclicSCC" AcyclicSCC <>
187 readsUnaryWith (const rl) "CyclicSCC" CyclicSCC
188 #endif
189
190 -- | @since 0.5.9
191 instance F.Foldable SCC where
192 foldr c n (AcyclicSCC v) = c v n
193 foldr c n (CyclicSCC vs) = foldr c n vs
194
195 -- | @since 0.5.9
196 instance Traversable SCC where
197 -- We treat the non-empty cyclic case specially to cut one
198 -- fmap application.
199 traverse f (AcyclicSCC vertex) = AcyclicSCC <$> f vertex
200 traverse _f (CyclicSCC []) = pure (CyclicSCC [])
201 traverse f (CyclicSCC (x : xs)) =
202 liftA2 (\x' xs' -> CyclicSCC (x' : xs')) (f x) (traverse f xs)
203
204 instance NFData a => NFData (SCC a) where
205 rnf (AcyclicSCC v) = rnf v
206 rnf (CyclicSCC vs) = rnf vs
207
208 -- | @since 0.5.4
209 instance Functor SCC where
210 fmap f (AcyclicSCC v) = AcyclicSCC (f v)
211 fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)
212
213 -- | The vertices of a list of strongly connected components.
214 flattenSCCs :: [SCC a] -> [a]
215 flattenSCCs = concatMap flattenSCC
216
217 -- | The vertices of a strongly connected component.
218 flattenSCC :: SCC vertex -> [vertex]
219 flattenSCC (AcyclicSCC v) = [v]
220 flattenSCC (CyclicSCC vs) = vs
221
222 -- | The strongly connected components of a directed graph, reverse topologically
223 -- sorted.
224 --
225 -- ==== __Examples__
226 --
227 -- > stronglyConnComp [("a",0,[1]),("b",1,[2,3]),("c",2,[1]),("d",3,[3])]
228 -- > == [CyclicSCC ["d"],CyclicSCC ["b","c"],AcyclicSCC "a"]
229 stronglyConnComp
230 :: Ord key
231 => [(node, key, [key])]
232 -- ^ The graph: a list of nodes uniquely identified by keys,
233 -- with a list of keys of nodes this node has edges to.
234 -- The out-list may contain keys that don't correspond to
235 -- nodes of the graph; such edges are ignored.
236 -> [SCC node]
237
238 stronglyConnComp edges0
239 = map get_node (stronglyConnCompR edges0)
240 where
241 get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
242 get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]
243
244 -- | The strongly connected components of a directed graph, reverse topologically
245 -- sorted. The function is the same as 'stronglyConnComp', except that
246 -- all the information about each node retained.
247 -- This interface is used when you expect to apply 'SCC' to
248 -- (some of) the result of 'SCC', so you don't want to lose the
249 -- dependency information.
250 --
251 -- ==== __Examples__
252 --
253 -- > stronglyConnCompR [("a",0,[1]),("b",1,[2,3]),("c",2,[1]),("d",3,[3])]
254 -- > == [CyclicSCC [("d",3,[3])],CyclicSCC [("b",1,[2,3]),("c",2,[1])],AcyclicSCC ("a",0,[1])]
255 stronglyConnCompR
256 :: Ord key
257 => [(node, key, [key])]
258 -- ^ The graph: a list of nodes uniquely identified by keys,
259 -- with a list of keys of nodes this node has edges to.
260 -- The out-list may contain keys that don't correspond to
261 -- nodes of the graph; such edges are ignored.
262 -> [SCC (node, key, [key])] -- ^ Reverse topologically sorted
263
264 stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
265 stronglyConnCompR edges0
266 = map decode forest
267 where
268 (graph, vertex_fn,_) = graphFromEdges edges0
269 forest = scc graph
270 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
271 | otherwise = AcyclicSCC (vertex_fn v)
272 decode other = CyclicSCC (dec other [])
273 where
274 dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
275 mentions_itself v = v `elem` (graph ! v)
276
277 -------------------------------------------------------------------------
278 -- -
279 -- Graphs
280 -- -
281 -------------------------------------------------------------------------
282
283 -- | Abstract representation of vertices.
284 type Vertex = Int
285 -- | Table indexed by a contiguous set of vertices.
286 --
287 -- /Note: This is included for backwards compatibility./
288 type Table a = Array Vertex a
289 -- | Adjacency list representation of a graph, mapping each vertex to its
290 -- list of successors.
291 type Graph = Array Vertex [Vertex]
292 -- | The bounds of an @Array@.
293 type Bounds = (Vertex, Vertex)
294 -- | An edge from the first vertex to the second.
295 type Edge = (Vertex, Vertex)
296
297 #if !USE_UNBOXED_ARRAYS
298 type UArray i a = Array i a
299 #endif
300
301 -- | Returns the list of vertices in the graph.
302 --
303 -- ==== __Examples__
304 --
305 -- > vertices (buildG (0,-1) []) == []
306 --
307 -- > vertices (buildG (0,2) [(0,1),(1,2)]) == [0,1,2]
308 vertices :: Graph -> [Vertex]
309 vertices = indices
310
311 -- | Returns the list of edges in the graph.
312 --
313 -- ==== __Examples__
314 --
315 -- > edges (buildG (0,-1) []) == []
316 --
317 -- > edges (buildG (0,2) [(0,1),(1,2)]) == [(0,1),(1,2)]
318 edges :: Graph -> [Edge]
319 edges g = [ (v, w) | v <- vertices g, w <- g!v ]
320
321 -- | Build a graph from a list of edges.
322 --
323 -- Warning: This function will cause a runtime exception if a vertex in the edge
324 -- list is not within the given @Bounds@.
325 --
326 -- ==== __Examples__
327 --
328 -- > buildG (0,-1) [] == array (0,-1) []
329 -- > buildG (0,2) [(0,1), (1,2)] == array (0,1) [(0,[1]),(1,[2])]
330 -- > buildG (0,2) [(0,1), (0,2), (1,2)] == array (0,2) [(0,[2,1]),(1,[2]),(2,[])]
331 buildG :: Bounds -> [Edge] -> Graph
332 buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0
333
334 -- | The graph obtained by reversing all edges.
335 --
336 -- ==== __Examples__
337 --
338 -- > transposeG (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,[]),(1,[0]),(2,[1])]
339 transposeG :: Graph -> Graph
340 transposeG g = buildG (bounds g) (reverseE g)
341
342 reverseE :: Graph -> [Edge]
343 reverseE g = [ (w, v) | (v, w) <- edges g ]
344
345 -- | A table of the count of edges from each node.
346 --
347 -- ==== __Examples__
348 --
349 -- > outdegree (buildG (0,-1) []) == array (0,-1) []
350 --
351 -- > outdegree (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,1),(1,1),(2,0)]
352 outdegree :: Graph -> Array Vertex Int
353 -- This is bizarrely lazy. We build an array filled with thunks, instead
354 -- of actually calculating anything. This is the historical behavior, and I
355 -- suppose someone *could* be relying on it, but it might be worth finding
356 -- out. Note that we *can't* be so lazy with indegree.
357 outdegree = fmap length
358
359 -- | A table of the count of edges into each node.
360 --
361 -- ==== __Examples__
362 --
363 -- > indegree (buildG (0,-1) []) == array (0,-1) []
364 --
365 -- > indegree (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,0),(1,1),(2,1)]
366 indegree :: Graph -> Array Vertex Int
367 indegree g = accumArray (+) 0 (bounds g) [(v, 1) | (_, outs) <- assocs g, v <- outs]
368
369 -- | Identical to 'graphFromEdges', except that the return value
370 -- does not include the function which maps keys to vertices. This
371 -- version of 'graphFromEdges' is for backwards compatibility.
372 graphFromEdges'
373 :: Ord key
374 => [(node, key, [key])]
375 -> (Graph, Vertex -> (node, key, [key]))
376 graphFromEdges' x = (a,b) where
377 (a,b,_) = graphFromEdges x
378
379 -- | Build a graph from a list of nodes uniquely identified by keys,
380 -- with a list of keys of nodes this node should have edges to.
381 --
382 -- This function takes an adjacency list representing a graph with vertices of
383 -- type @key@ labeled by values of type @node@ and produces a @Graph@-based
384 -- representation of that list. The @Graph@ result represents the /shape/ of the
385 -- graph, and the functions describe a) how to retrieve the label and adjacent
386 -- vertices of a given vertex, and b) how to retrive a vertex given a key.
387 --
388 -- @(graph, nodeFromVertex, vertexFromKey) = graphFromEdges edgeList@
389 --
390 -- * @graph :: Graph@ is the raw, array based adjacency list for the graph.
391 -- * @nodeFromVertex :: Vertex -> (node, key, [key])@ returns the node
392 -- associated with the given 0-based @Int@ vertex; see /warning/ below.
393 -- * @vertexFromKey :: key -> Maybe Vertex@ returns the @Int@ vertex for the
394 -- key if it exists in the graph, @Nothing@ otherwise.
395 --
396 -- To safely use this API you must either extract the list of vertices directly
397 -- from the graph or first call @vertexFromKey k@ to check if a vertex
398 -- corresponds to the key @k@. Once it is known that a vertex exists you can use
399 -- @nodeFromVertex@ to access the labelled node and adjacent vertices. See below
400 -- for examples.
401 --
402 -- Note: The out-list may contain keys that don't correspond to nodes of the
403 -- graph; they are ignored.
404 --
405 -- Warning: The @nodeFromVertex@ function will cause a runtime exception if the
406 -- given @Vertex@ does not exist.
407 --
408 -- ==== __Examples__
409 --
410 -- An empty graph.
411 --
412 -- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges []
413 -- > graph = array (0,-1) []
414 --
415 -- A graph where the out-list references unspecified nodes (@\'c\'@), these are
416 -- ignored.
417 --
418 -- > (graph, _, _) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c'])]
419 -- > array (0,1) [(0,[1]),(1,[])]
420 --
421 --
422 -- A graph with 3 vertices: ("a") -> ("b") -> ("c")
423 --
424 -- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c']), ("c", 'c', [])]
425 -- > graph == array (0,2) [(0,[1]),(1,[2]),(2,[])]
426 -- > nodeFromVertex 0 == ("a",'a',"b")
427 -- > vertexFromKey 'a' == Just 0
428 --
429 -- Get the label for a given key.
430 --
431 -- > let getNodePart (n, _, _) = n
432 -- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c']), ("c", 'c', [])]
433 -- > getNodePart . nodeFromVertex <$> vertexFromKey 'a' == Just "A"
434 --
435 graphFromEdges
436 :: Ord key
437 => [(node, key, [key])]
438 -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
439 graphFromEdges edges0
440 = (graph, \v -> vertex_map ! v, key_vertex)
441 where
442 max_v = length edges0 - 1
443 bounds0 = (0,max_v) :: (Vertex, Vertex)
444 sorted_edges = sortBy lt edges0
445 edges1 = zipWith (,) [0..] sorted_edges
446
447 graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
448 key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1]
449 vertex_map = array bounds0 edges1
450
451 (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
452
453 -- key_vertex :: key -> Maybe Vertex
454 -- returns Nothing for non-interesting vertices
455 key_vertex k = findVertex 0 max_v
456 where
457 findVertex a b | a > b
458 = Nothing
459 findVertex a b = case compare k (key_map ! mid) of
460 LT -> findVertex a (mid-1)
461 EQ -> Just mid
462 GT -> findVertex (mid+1) b
463 where
464 mid = a + (b - a) `div` 2
465
466 -------------------------------------------------------------------------
467 -- -
468 -- Depth first search
469 -- -
470 -------------------------------------------------------------------------
471
472 -- | A spanning forest of the graph, obtained from a depth-first search of
473 -- the graph starting from each vertex in an unspecified order.
474 dff :: Graph -> Forest Vertex
475 dff g = dfs g (vertices g)
476
477 -- | A spanning forest of the part of the graph reachable from the listed
478 -- vertices, obtained from a depth-first search of the graph starting at
479 -- each of the listed vertices in order.
480 dfs :: Graph -> [Vertex] -> Forest Vertex
481 dfs g vs = prune (bounds g) (map (generate g) vs)
482
483 generate :: Graph -> Vertex -> Tree Vertex
484 generate g v = Node v (map (generate g) (g!v))
485
486 prune :: Bounds -> Forest Vertex -> Forest Vertex
487 prune bnds ts = run bnds (chop ts)
488
489 chop :: Forest Vertex -> SetM s (Forest Vertex)
490 chop [] = return []
491 chop (Node v ts : us)
492 = do
493 visited <- contains v
494 if visited then
495 chop us
496 else do
497 include v
498 as <- chop ts
499 bs <- chop us
500 return (Node v as : bs)
501
502 -- A monad holding a set of vertices visited so far.
503 #if USE_ST_MONAD
504
505 -- Use the ST monad if available, for constant-time primitives.
506
507 #if USE_UNBOXED_ARRAYS
508 newtype SetM s a = SetM { runSetM :: STUArray s Vertex Bool -> ST s a }
509 #else
510 newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a }
511 #endif
512
513 instance Monad (SetM s) where
514 return = pure
515 {-# INLINE return #-}
516 SetM v >>= f = SetM $ \s -> do { x <- v s; runSetM (f x) s }
517 {-# INLINE (>>=) #-}
518
519 instance Functor (SetM s) where
520 f `fmap` SetM v = SetM $ \s -> f `fmap` v s
521 {-# INLINE fmap #-}
522
523 instance Applicative (SetM s) where
524 pure x = SetM $ const (return x)
525 {-# INLINE pure #-}
526 SetM f <*> SetM v = SetM $ \s -> f s >>= (`fmap` v s)
527 -- We could also use the following definition
528 -- SetM f <*> SetM v = SetM $ \s -> f s <*> v s
529 -- but Applicative (ST s) instance is present only in GHC 7.2+
530 {-# INLINE (<*>) #-}
531
532 run :: Bounds -> (forall s. SetM s a) -> a
533 run bnds act = runST (newArray bnds False >>= runSetM act)
534
535 contains :: Vertex -> SetM s Bool
536 contains v = SetM $ \ m -> readArray m v
537
538 include :: Vertex -> SetM s ()
539 include v = SetM $ \ m -> writeArray m v True
540
541 #else /* !USE_ST_MONAD */
542
543 -- Portable implementation using IntSet.
544
545 newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }
546
547 instance Monad (SetM s) where
548 return x = SetM $ \s -> (x, s)
549 SetM v >>= f = SetM $ \s -> case v s of (x, s') -> runSetM (f x) s'
550
551 instance Functor (SetM s) where
552 f `fmap` SetM v = SetM $ \s -> case v s of (x, s') -> (f x, s')
553 {-# INLINE fmap #-}
554
555 instance Applicative (SetM s) where
556 pure x = SetM $ \s -> (x, s)
557 {-# INLINE pure #-}
558 SetM f <*> SetM v = SetM $ \s -> case f s of (k, s') -> case v s' of (x, s'') -> (k x, s'')
559 {-# INLINE (<*>) #-}
560
561 run :: Bounds -> SetM s a -> a
562 run _ act = fst (runSetM act Set.empty)
563
564 contains :: Vertex -> SetM s Bool
565 contains v = SetM $ \ m -> (Set.member v m, m)
566
567 include :: Vertex -> SetM s ()
568 include v = SetM $ \ m -> ((), Set.insert v m)
569
570 #endif /* !USE_ST_MONAD */
571
572 -------------------------------------------------------------------------
573 -- -
574 -- Algorithms
575 -- -
576 -------------------------------------------------------------------------
577
578 ------------------------------------------------------------
579 -- Algorithm 1: depth first search numbering
580 ------------------------------------------------------------
581
582 preorder' :: Tree a -> [a] -> [a]
583 preorder' (Node a ts) = (a :) . preorderF' ts
584
585 preorderF' :: Forest a -> [a] -> [a]
586 preorderF' ts = foldr (.) id $ map preorder' ts
587
588 preorderF :: Forest a -> [a]
589 preorderF ts = preorderF' ts []
590
591 tabulate :: Bounds -> [Vertex] -> UArray Vertex Int
592 tabulate bnds vs = UA.array bnds (zipWith (flip (,)) [1..] vs)
593 -- Why zipWith (flip (,)) instead of just using zip with the
594 -- arguments in the other order? We want the [1..] to fuse
595 -- away, and these days that only happens when it's the first
596 -- list argument.
597
598 preArr :: Bounds -> Forest Vertex -> UArray Vertex Int
599 preArr bnds = tabulate bnds . preorderF
600
601 ------------------------------------------------------------
602 -- Algorithm 2: topological sorting
603 ------------------------------------------------------------
604
605 postorder :: Tree a -> [a] -> [a]
606 postorder (Node a ts) = postorderF ts . (a :)
607
608 postorderF :: Forest a -> [a] -> [a]
609 postorderF ts = foldr (.) id $ map postorder ts
610
611 postOrd :: Graph -> [Vertex]
612 postOrd g = postorderF (dff g) []
613
614 -- | A topological sort of the graph.
615 -- The order is partially specified by the condition that a vertex /i/
616 -- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.
617 topSort :: Graph -> [Vertex]
618 topSort = reverse . postOrd
619
620 ------------------------------------------------------------
621 -- Algorithm 3: connected components
622 ------------------------------------------------------------
623
624 -- | The connected components of a graph.
625 -- Two vertices are connected if there is a path between them, traversing
626 -- edges in either direction.
627 components :: Graph -> Forest Vertex
628 components = dff . undirected
629
630 undirected :: Graph -> Graph
631 undirected g = buildG (bounds g) (edges g ++ reverseE g)
632
633 -- Algorithm 4: strongly connected components
634
635 -- | The strongly connected components of a graph, in reverse topological order.
636 --
637 -- ==== __Examples__
638 --
639 -- > scc (buildG (0,3) [(3,1),(1,2),(2,0),(0,1)])
640 -- > == [Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []}]}]}
641 -- > ,Node {rootLabel = 3, subForest = []}]
642
643 scc :: Graph -> Forest Vertex
644 scc g = dfs g (reverse (postOrd (transposeG g)))
645
646 ------------------------------------------------------------
647 -- Algorithm 5: Classifying edges
648 ------------------------------------------------------------
649
650 {-
651 XXX unused code
652
653 tree :: Bounds -> Forest Vertex -> Graph
654 tree bnds ts = buildG bnds (concat (map flat ts))
655 where flat (Node v ts') = [ (v, w) | Node w _us <- ts' ]
656 ++ concat (map flat ts')
657
658 back :: Graph -> Table Int -> Graph
659 back g post = mapT select g
660 where select v ws = [ w | w <- ws, post!v < post!w ]
661
662 cross :: Graph -> Table Int -> Table Int -> Graph
663 cross g pre post = mapT select g
664 where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
665
666 forward :: Graph -> Graph -> Table Int -> Graph
667 forward g tree' pre = mapT select g
668 where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree' ! v
669
670 mapT :: (Vertex -> a -> b) -> Array Vertex a -> Array Vertex b
671 mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
672 -}
673
674 ------------------------------------------------------------
675 -- Algorithm 6: Finding reachable vertices
676 ------------------------------------------------------------
677
678 -- | Returns the list of vertices reachable from a given vertex.
679 --
680 -- ==== __Examples__
681 --
682 -- > reachable (buildG (0,0) []) 0 == [0]
683 --
684 -- > reachable (buildG (0,2) [(0,1), (1,2)]) 0 == [0,1,2]
685 reachable :: Graph -> Vertex -> [Vertex]
686 reachable g v = preorderF (dfs g [v])
687
688 -- | Returns @True@ if the second vertex reachable from the first.
689 --
690 -- ==== __Examples__
691 --
692 -- > path (buildG (0,0) []) 0 0 == True
693 --
694 -- > path (buildG (0,2) [(0,1), (1,2)]) 0 2 == True
695 --
696 -- > path (buildG (0,2) [(0,1), (1,2)]) 2 0 == False
697 path :: Graph -> Vertex -> Vertex -> Bool
698 path g v w = w `elem` (reachable g v)
699
700 ------------------------------------------------------------
701 -- Algorithm 7: Biconnected components
702 ------------------------------------------------------------
703
704 -- | The biconnected components of a graph.
705 -- An undirected graph is biconnected if the deletion of any vertex
706 -- leaves it connected.
707 bcc :: Graph -> Forest [Vertex]
708 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
709 where forest = dff g
710 dnum = preArr (bounds g) forest
711
712 do_label :: Graph -> UArray Vertex Int -> Tree Vertex -> Tree (Vertex,Int,Int)
713 do_label g dnum (Node v ts) = Node (v, dnum UA.! v, lv) us
714 where us = map (do_label g dnum) ts
715 lv = minimum ([dnum UA.! v] ++ [dnum UA.! w | w <- g!v]
716 ++ [lu | Node (_,_,lu) _ <- us])
717
718 bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
719 bicomps (Node (v,_,_) ts)
720 = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]
721
722 collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
723 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
724 where collected = map collect ts
725 vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv]
726 cs = concat [ if lw<dv then us else [Node (v:ws) us]
727 | (lw, Node ws us) <- collected ]