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