Remove pair rules (#253)
[packages/containers.git] / Data / Graph.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__
3 {-# LANGUAGE Rank2Types #-}
4 #endif
5 #if __GLASGOW_HASKELL__ >= 703
6 {-# LANGUAGE Trustworthy #-}
7 #endif
8
9 #include "containers.h"
10
11 -----------------------------------------------------------------------------
12 -- |
13 -- Module : Data.Graph
14 -- Copyright : (c) The University of Glasgow 2002
15 -- License : BSD-style (see the file libraries/base/LICENSE)
16 --
17 -- Maintainer : libraries@haskell.org
18 -- Stability : experimental
19 -- Portability : portable
20 --
21 -- A version of the graph algorithms described in:
22 --
23 -- /Structuring Depth-First Search Algorithms in Haskell/,
24 -- by David King and John Launchbury.
25 --
26 -----------------------------------------------------------------------------
27
28 module Data.Graph(
29
30 -- * External interface
31
32 -- At present the only one with a "nice" external interface
33 stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
34
35 -- * Graphs
36
37 Graph, Table, Bounds, Edge, Vertex,
38
39 -- ** Building graphs
40
41 graphFromEdges, graphFromEdges', buildG, transposeG,
42 -- reverseE,
43
44 -- ** Graph properties
45
46 vertices, edges,
47 outdegree, indegree,
48
49 -- * Algorithms
50
51 dfs, dff,
52 topSort,
53 components,
54 scc,
55 bcc,
56 -- tree, back, cross, forward,
57 reachable, path,
58
59 module Data.Tree
60
61 ) where
62
63 #if __GLASGOW_HASKELL__
64 # define USE_ST_MONAD 1
65 #endif
66
67 -- Extensions
68 #if USE_ST_MONAD
69 import Control.Monad.ST
70 import Data.Array.ST (STArray, newArray, readArray, writeArray)
71 #else
72 import Data.IntSet (IntSet)
73 import qualified Data.IntSet as Set
74 #endif
75 import Data.Tree (Tree(Node), Forest)
76
77 -- std interfaces
78 #if !MIN_VERSION_base(4,8,0)
79 import Control.Applicative
80 #endif
81 import Control.DeepSeq (NFData(rnf))
82 import Data.Maybe
83 import Data.Array
84 import Data.List
85
86 -------------------------------------------------------------------------
87 -- -
88 -- External interface
89 -- -
90 -------------------------------------------------------------------------
91
92 -- | Strongly connected component.
93 data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not
94 -- in any cycle.
95 | CyclicSCC [vertex] -- ^ A maximal set of mutually
96 -- reachable vertices.
97
98 instance NFData a => NFData (SCC a) where
99 rnf (AcyclicSCC v) = rnf v
100 rnf (CyclicSCC vs) = rnf vs
101
102 instance Functor SCC where
103 fmap f (AcyclicSCC v) = AcyclicSCC (f v)
104 fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)
105
106 -- | The vertices of a list of strongly connected components.
107 flattenSCCs :: [SCC a] -> [a]
108 flattenSCCs = concatMap flattenSCC
109
110 -- | The vertices of a strongly connected component.
111 flattenSCC :: SCC vertex -> [vertex]
112 flattenSCC (AcyclicSCC v) = [v]
113 flattenSCC (CyclicSCC vs) = vs
114
115 -- | The strongly connected components of a directed graph, topologically
116 -- sorted.
117 stronglyConnComp
118 :: Ord key
119 => [(node, key, [key])]
120 -- ^ The graph: a list of nodes uniquely identified by keys,
121 -- with a list of keys of nodes this node has edges to.
122 -- The out-list may contain keys that don't correspond to
123 -- nodes of the graph; such edges are ignored.
124 -> [SCC node]
125
126 stronglyConnComp edges0
127 = map get_node (stronglyConnCompR edges0)
128 where
129 get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
130 get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]
131
132 -- | The strongly connected components of a directed graph, topologically
133 -- sorted. The function is the same as 'stronglyConnComp', except that
134 -- all the information about each node retained.
135 -- This interface is used when you expect to apply 'SCC' to
136 -- (some of) the result of 'SCC', so you don't want to lose the
137 -- dependency information.
138 stronglyConnCompR
139 :: Ord key
140 => [(node, key, [key])]
141 -- ^ The graph: a list of nodes uniquely identified by keys,
142 -- with a list of keys of nodes this node has edges to.
143 -- The out-list may contain keys that don't correspond to
144 -- nodes of the graph; such edges are ignored.
145 -> [SCC (node, key, [key])] -- ^ Topologically sorted
146
147 stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
148 stronglyConnCompR edges0
149 = map decode forest
150 where
151 (graph, vertex_fn,_) = graphFromEdges edges0
152 forest = scc graph
153 decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
154 | otherwise = AcyclicSCC (vertex_fn v)
155 decode other = CyclicSCC (dec other [])
156 where
157 dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
158 mentions_itself v = v `elem` (graph ! v)
159
160 -------------------------------------------------------------------------
161 -- -
162 -- Graphs
163 -- -
164 -------------------------------------------------------------------------
165
166 -- | Abstract representation of vertices.
167 type Vertex = Int
168 -- | Table indexed by a contiguous set of vertices.
169 type Table a = Array Vertex a
170 -- | Adjacency list representation of a graph, mapping each vertex to its
171 -- list of successors.
172 type Graph = Table [Vertex]
173 -- | The bounds of a 'Table'.
174 type Bounds = (Vertex, Vertex)
175 -- | An edge from the first vertex to the second.
176 type Edge = (Vertex, Vertex)
177
178 -- | All vertices of a graph.
179 vertices :: Graph -> [Vertex]
180 vertices = indices
181
182 -- | All edges of a graph.
183 edges :: Graph -> [Edge]
184 edges g = [ (v, w) | v <- vertices g, w <- g!v ]
185
186 mapT :: (Vertex -> a -> b) -> Table a -> Table b
187 mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
188
189 -- | Build a graph from a list of edges.
190 buildG :: Bounds -> [Edge] -> Graph
191 buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0
192
193 -- | The graph obtained by reversing all edges.
194 transposeG :: Graph -> Graph
195 transposeG g = buildG (bounds g) (reverseE g)
196
197 reverseE :: Graph -> [Edge]
198 reverseE g = [ (w, v) | (v, w) <- edges g ]
199
200 -- | A table of the count of edges from each node.
201 outdegree :: Graph -> Table Int
202 outdegree = mapT numEdges
203 where numEdges _ ws = length ws
204
205 -- | A table of the count of edges into each node.
206 indegree :: Graph -> Table Int
207 indegree = outdegree . transposeG
208
209 -- | Identical to 'graphFromEdges', except that the return value
210 -- does not include the function which maps keys to vertices. This
211 -- version of 'graphFromEdges' is for backwards compatibility.
212 graphFromEdges'
213 :: Ord key
214 => [(node, key, [key])]
215 -> (Graph, Vertex -> (node, key, [key]))
216 graphFromEdges' x = (a,b) where
217 (a,b,_) = graphFromEdges x
218
219 -- | Build a graph from a list of nodes uniquely identified by keys,
220 -- with a list of keys of nodes this node should have edges to.
221 -- The out-list may contain keys that don't correspond to
222 -- nodes of the graph; they are ignored.
223 graphFromEdges
224 :: Ord key
225 => [(node, key, [key])]
226 -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
227 graphFromEdges edges0
228 = (graph, \v -> vertex_map ! v, key_vertex)
229 where
230 max_v = length edges0 - 1
231 bounds0 = (0,max_v) :: (Vertex, Vertex)
232 sorted_edges = sortBy lt edges0
233 edges1 = zipWith (,) [0..] sorted_edges
234
235 graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
236 key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1]
237 vertex_map = array bounds0 edges1
238
239 (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
240
241 -- key_vertex :: key -> Maybe Vertex
242 -- returns Nothing for non-interesting vertices
243 key_vertex k = findVertex 0 max_v
244 where
245 findVertex a b | a > b
246 = Nothing
247 findVertex a b = case compare k (key_map ! mid) of
248 LT -> findVertex a (mid-1)
249 EQ -> Just mid
250 GT -> findVertex (mid+1) b
251 where
252 mid = a + (b - a) `div` 2
253
254 -------------------------------------------------------------------------
255 -- -
256 -- Depth first search
257 -- -
258 -------------------------------------------------------------------------
259
260 -- | A spanning forest of the graph, obtained from a depth-first search of
261 -- the graph starting from each vertex in an unspecified order.
262 dff :: Graph -> Forest Vertex
263 dff g = dfs g (vertices g)
264
265 -- | A spanning forest of the part of the graph reachable from the listed
266 -- vertices, obtained from a depth-first search of the graph starting at
267 -- each of the listed vertices in order.
268 dfs :: Graph -> [Vertex] -> Forest Vertex
269 dfs g vs = prune (bounds g) (map (generate g) vs)
270
271 generate :: Graph -> Vertex -> Tree Vertex
272 generate g v = Node v (map (generate g) (g!v))
273
274 prune :: Bounds -> Forest Vertex -> Forest Vertex
275 prune bnds ts = run bnds (chop ts)
276
277 chop :: Forest Vertex -> SetM s (Forest Vertex)
278 chop [] = return []
279 chop (Node v ts : us)
280 = do
281 visited <- contains v
282 if visited then
283 chop us
284 else do
285 include v
286 as <- chop ts
287 bs <- chop us
288 return (Node v as : bs)
289
290 -- A monad holding a set of vertices visited so far.
291 #if USE_ST_MONAD
292
293 -- Use the ST monad if available, for constant-time primitives.
294
295 newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a }
296
297 instance Monad (SetM s) where
298 return = pure
299 {-# INLINE return #-}
300 SetM v >>= f = SetM $ \s -> do { x <- v s; runSetM (f x) s }
301 {-# INLINE (>>=) #-}
302
303 instance Functor (SetM s) where
304 f `fmap` SetM v = SetM $ \s -> f `fmap` v s
305 {-# INLINE fmap #-}
306
307 instance Applicative (SetM s) where
308 pure x = SetM $ const (return x)
309 {-# INLINE pure #-}
310 SetM f <*> SetM v = SetM $ \s -> f s >>= (`fmap` v s)
311 -- We could also use the following definition
312 -- SetM f <*> SetM v = SetM $ \s -> f s <*> v s
313 -- but Applicative (ST s) instance is present only in GHC 7.2+
314 {-# INLINE (<*>) #-}
315
316 run :: Bounds -> (forall s. SetM s a) -> a
317 run bnds act = runST (newArray bnds False >>= runSetM act)
318
319 contains :: Vertex -> SetM s Bool
320 contains v = SetM $ \ m -> readArray m v
321
322 include :: Vertex -> SetM s ()
323 include v = SetM $ \ m -> writeArray m v True
324
325 #else /* !USE_ST_MONAD */
326
327 -- Portable implementation using IntSet.
328
329 newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }
330
331 instance Monad (SetM s) where
332 return x = SetM $ \s -> (x, s)
333 SetM v >>= f = SetM $ \s -> case v s of (x, s') -> runSetM (f x) s'
334
335 instance Functor (SetM s) where
336 f `fmap` SetM v = SetM $ \s -> case v s of (x, s') -> (f x, s')
337 {-# INLINE fmap #-}
338
339 instance Applicative (SetM s) where
340 pure x = SetM $ \s -> (x, s)
341 {-# INLINE pure #-}
342 SetM f <*> SetM v = SetM $ \s -> case f s of (k, s') -> case v s' of (x, s'') -> (k x, s'')
343 {-# INLINE (<*>) #-}
344
345 run :: Bounds -> SetM s a -> a
346 run _ act = fst (runSetM act Set.empty)
347
348 contains :: Vertex -> SetM s Bool
349 contains v = SetM $ \ m -> (Set.member v m, m)
350
351 include :: Vertex -> SetM s ()
352 include v = SetM $ \ m -> ((), Set.insert v m)
353
354 #endif /* !USE_ST_MONAD */
355
356 -------------------------------------------------------------------------
357 -- -
358 -- Algorithms
359 -- -
360 -------------------------------------------------------------------------
361
362 ------------------------------------------------------------
363 -- Algorithm 1: depth first search numbering
364 ------------------------------------------------------------
365
366 preorder' :: Tree a -> [a] -> [a]
367 preorder' (Node a ts) = (a :) . preorderF' ts
368
369 preorderF' :: Forest a -> [a] -> [a]
370 preorderF' ts = foldr (.) id $ map preorder' ts
371
372 preorderF :: Forest a -> [a]
373 preorderF ts = preorderF' ts []
374
375 tabulate :: Bounds -> [Vertex] -> Table Int
376 tabulate bnds vs = array bnds (zipWith (,) vs [1..])
377
378 preArr :: Bounds -> Forest Vertex -> Table Int
379 preArr bnds = tabulate bnds . preorderF
380
381 ------------------------------------------------------------
382 -- Algorithm 2: topological sorting
383 ------------------------------------------------------------
384
385 postorder :: Tree a -> [a] -> [a]
386 postorder (Node a ts) = postorderF ts . (a :)
387
388 postorderF :: Forest a -> [a] -> [a]
389 postorderF ts = foldr (.) id $ map postorder ts
390
391 postOrd :: Graph -> [Vertex]
392 postOrd g = postorderF (dff g) []
393
394 -- | A topological sort of the graph.
395 -- The order is partially specified by the condition that a vertex /i/
396 -- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.
397 topSort :: Graph -> [Vertex]
398 topSort = reverse . postOrd
399
400 ------------------------------------------------------------
401 -- Algorithm 3: connected components
402 ------------------------------------------------------------
403
404 -- | The connected components of a graph.
405 -- Two vertices are connected if there is a path between them, traversing
406 -- edges in either direction.
407 components :: Graph -> Forest Vertex
408 components = dff . undirected
409
410 undirected :: Graph -> Graph
411 undirected g = buildG (bounds g) (edges g ++ reverseE g)
412
413 -- Algorithm 4: strongly connected components
414
415 -- | The strongly connected components of a graph.
416 scc :: Graph -> Forest Vertex
417 scc g = dfs g (reverse (postOrd (transposeG g)))
418
419 ------------------------------------------------------------
420 -- Algorithm 5: Classifying edges
421 ------------------------------------------------------------
422
423 {-
424 XXX unused code
425
426 tree :: Bounds -> Forest Vertex -> Graph
427 tree bnds ts = buildG bnds (concat (map flat ts))
428 where flat (Node v ts') = [ (v, w) | Node w _us <- ts' ]
429 ++ concat (map flat ts')
430
431 back :: Graph -> Table Int -> Graph
432 back g post = mapT select g
433 where select v ws = [ w | w <- ws, post!v < post!w ]
434
435 cross :: Graph -> Table Int -> Table Int -> Graph
436 cross g pre post = mapT select g
437 where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
438
439 forward :: Graph -> Graph -> Table Int -> Graph
440 forward g tree' pre = mapT select g
441 where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree' ! v
442 -}
443
444 ------------------------------------------------------------
445 -- Algorithm 6: Finding reachable vertices
446 ------------------------------------------------------------
447
448 -- | A list of vertices reachable from a given vertex.
449 reachable :: Graph -> Vertex -> [Vertex]
450 reachable g v = preorderF (dfs g [v])
451
452 -- | Is the second vertex reachable from the first?
453 path :: Graph -> Vertex -> Vertex -> Bool
454 path g v w = w `elem` (reachable g v)
455
456 ------------------------------------------------------------
457 -- Algorithm 7: Biconnected components
458 ------------------------------------------------------------
459
460 -- | The biconnected components of a graph.
461 -- An undirected graph is biconnected if the deletion of any vertex
462 -- leaves it connected.
463 bcc :: Graph -> Forest [Vertex]
464 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
465 where forest = dff g
466 dnum = preArr (bounds g) forest
467
468 do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
469 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
470 where us = map (do_label g dnum) ts
471 lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
472 ++ [lu | Node (_,_,lu) _ <- us])
473
474 bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
475 bicomps (Node (v,_,_) ts)
476 = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]
477
478 collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
479 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
480 where collected = map collect ts
481 vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv]
482 cs = concat [ if lw<dv then us else [Node (v:ws) us]
483 | (lw, Node ws us) <- collected ]