Digraph.lhs 13.5 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1
2
3
4
%
% (c) The University of Glasgow 2006
%

5
\begin{code}
6
{-# OPTIONS -w #-}
7
8
9
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
10
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
11
12
-- for details

sof's avatar
sof committed
13
14
module Digraph(

Ian Lynagh's avatar
Ian Lynagh committed
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
        -- At present the only one with a "nice" external interface
        stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,

        Graph, Vertex,
        graphFromEdges, graphFromEdges',
        buildG, transposeG, reverseE, outdegree, indegree,

        Tree(..), Forest,
        showTree, showForest,

        dfs, dff,
        topSort,
        components,
        scc,
        back, cross, forward,
        reachable, path,
        bcc
32
33
    ) where

34
35
# include "HsVersions.h"

sof's avatar
sof committed
36
37
------------------------------------------------------------------------------
-- A version of the graph algorithms described in:
Ian Lynagh's avatar
Ian Lynagh committed
38
--
sof's avatar
sof committed
39
40
-- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
--   by David King and John Launchbury
Ian Lynagh's avatar
Ian Lynagh committed
41
--
sof's avatar
sof committed
42
43
44
45
-- Also included is some additional code for printing tree structures ...
------------------------------------------------------------------------------


Ian Lynagh's avatar
Ian Lynagh committed
46
import Util        ( sortLe )
Simon Marlow's avatar
Simon Marlow committed
47
import Outputable
48

49
-- Extensions
Simon Marlow's avatar
Simon Marlow committed
50
import Control.Monad.ST
51
52

-- std interfaces
Simon Marlow's avatar
Simon Marlow committed
53
54
55
import Data.Maybe
import Data.Array
import Data.List
56

ei@vuokko.info's avatar
ei@vuokko.info committed
57
58
#if __GLASGOW_HASKELL__ > 604
import Data.Array.ST
59
#else
Simon Marlow's avatar
Simon Marlow committed
60
import Data.Array.ST  hiding ( indices, bounds )
61
#endif
62
63
64
\end{code}


sof's avatar
sof committed
65
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
66
67
68
%*                                                                      *
%*      External interface
%*                                                                      *
sof's avatar
sof committed
69
70
71
72
%************************************************************************

\begin{code}
data SCC vertex = AcyclicSCC vertex
Ian Lynagh's avatar
Ian Lynagh committed
73
                | CyclicSCC  [vertex]
sof's avatar
sof committed
74

75
76
77
78
79
flattenSCCs :: [SCC a] -> [a]
flattenSCCs = concatMap flattenSCC

flattenSCC (AcyclicSCC v) = [v]
flattenSCC (CyclicSCC vs) = vs
80
81
82
83

instance Outputable a => Outputable (SCC a) where
   ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
   ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
84
85
\end{code}

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
86
87
88
89
90
91
92
93
94
95
Note [Nodes, keys, vertices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * A 'node' is a big blob of client-stuff

 * Each 'node' has a unique (client) 'key', but the latter 
	is in Ord and has fast comparison

 * Digraph then maps each 'key' to a Vertex (Int) which is
  	arranged densely in 0.n

96
\begin{code}
sof's avatar
sof committed
97
stronglyConnComp
Ian Lynagh's avatar
Ian Lynagh committed
98
99
100
101
102
103
        :: Ord key
        => [(node, key, [key])]         -- The graph; its ok for the
                                        -- out-list to contain keys which arent
                                        -- a vertex key, they are ignored
        -> [SCC node]   -- Returned in topologically sorted order
                        -- Later components depend on earlier ones, but not vice versa
sof's avatar
sof committed
104
105
106
107
108
109
110
111
112
113

stronglyConnComp edges
  = map get_node (stronglyConnCompR edges)
  where
    get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
    get_node (CyclicSCC triples)     = CyclicSCC [n | (n,_,_) <- triples]

-- The "R" interface is used when you expect to apply SCC to
-- the (some of) the result of SCC, so you dont want to lose the dependency info
stronglyConnCompR
Ian Lynagh's avatar
Ian Lynagh committed
114
115
116
117
118
        :: Ord key
        => [(node, key, [key])]         -- The graph; its ok for the
                                        -- out-list to contain keys which arent
                                        -- a vertex key, they are ignored
        -> [SCC (node, key, [key])]     -- Topologically sorted
sof's avatar
sof committed
119
120
121
122
123

stronglyConnCompR [] = []  -- added to avoid creating empty array in graphFromEdges -- SOF
stronglyConnCompR edges
  = map decode forest
  where
124
125
    (graph, vertex_fn) = {-# SCC "graphFromEdges" #-} graphFromEdges edges
    forest             = {-# SCC "Digraph.scc" #-} scc graph
sof's avatar
sof committed
126
    decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
Ian Lynagh's avatar
Ian Lynagh committed
127
                       | otherwise         = AcyclicSCC (vertex_fn v)
sof's avatar
sof committed
128
    decode other = CyclicSCC (dec other [])
Ian Lynagh's avatar
Ian Lynagh committed
129
130
                 where
                   dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
sof's avatar
sof committed
131
132
    mentions_itself v = v `elem` (graph ! v)
\end{code}
133
134

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
135
136
137
%*                                                                      *
%*      Graphs
%*                                                                      *
138
139
140
%************************************************************************


sof's avatar
sof committed
141
142
143
144
145
146
147
\begin{code}
type Vertex  = Int
type Table a = Array Vertex a
type Graph   = Table [Vertex]
type Bounds  = (Vertex, Vertex)
type Edge    = (Vertex, Vertex)
\end{code}
148
149

\begin{code}
sof's avatar
sof committed
150
151
vertices :: Graph -> [Vertex]
vertices  = indices
152

sof's avatar
sof committed
153
154
edges    :: Graph -> [Edge]
edges g   = [ (v, w) | v <- vertices g, w <- g!v ]
155

sof's avatar
sof committed
156
mapT    :: (Vertex -> a -> b) -> Table a -> Table b
Ian Lynagh's avatar
Ian Lynagh committed
157
mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ]
158

sof's avatar
sof committed
159
160
buildG :: Bounds -> [Edge] -> Graph
buildG bounds edges = accumArray (flip (:)) [] bounds edges
161

sof's avatar
sof committed
162
163
transposeG  :: Graph -> Graph
transposeG g = buildG (bounds g) (reverseE g)
164

sof's avatar
sof committed
165
166
reverseE    :: Graph -> [Edge]
reverseE g   = [ (w, v) | (v, w) <- edges g ]
167

sof's avatar
sof committed
168
169
170
outdegree :: Graph -> Table Int
outdegree  = mapT numEdges
             where numEdges v ws = length ws
171

sof's avatar
sof committed
172
173
indegree :: Graph -> Table Int
indegree  = outdegree . transposeG
174
175
\end{code}

sof's avatar
sof committed
176

177
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
178
179
180
181
182
183
graphFromEdges
        :: Ord key
        => [(node, key, [key])]
        -> (Graph, Vertex -> (node, key, [key]))
graphFromEdges edges =
  case graphFromEdges' edges of (graph, vertex_fn, _) -> (graph, vertex_fn)
184
185

graphFromEdges'
Ian Lynagh's avatar
Ian Lynagh committed
186
187
188
        :: Ord key
        => [(node, key, [key])]
        -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
189
190
graphFromEdges' edges
  = (graph, \v -> vertex_map ! v, key_vertex)
sof's avatar
sof committed
191
  where
Ian Lynagh's avatar
Ian Lynagh committed
192
    max_v           = length edges - 1
sof's avatar
sof committed
193
    bounds          = (0,max_v) :: (Vertex, Vertex)
194
    sorted_edges    = let
Ian Lynagh's avatar
Ian Lynagh committed
195
196
197
198
                         (_,k1,_) `le` (_,k2,_) = case k1 `compare` k2 of { GT -> False; other -> True }
                      in
                        sortLe le edges
    edges1          = zipWith (,) [0..] sorted_edges
sof's avatar
sof committed
199

Ian Lynagh's avatar
Ian Lynagh committed
200
201
202
203
204
    graph           = array bounds [ (v, mapMaybe key_vertex ks)
                               | (v, (_,    _, ks)) <- edges1]
    key_map         = array bounds [ (v, k)
                               | (v, (_,    k, _ )) <- edges1]
    vertex_map      = array bounds edges1
sof's avatar
sof committed
205
206
207


    -- key_vertex :: key -> Maybe Vertex
Ian Lynagh's avatar
Ian Lynagh committed
208
209
210
211
212
213
214
215
216
217
218
    --  returns Nothing for non-interesting vertices
    key_vertex k   = find 0 max_v
                   where
                     find a b | a > b
                              = Nothing
                     find a b = case compare k (key_map ! mid) of
                                   LT -> find a (mid-1)
                                   EQ -> Just mid
                                   GT -> find (mid+1) b
                              where
                                mid = (a + b) `div` 2
sof's avatar
sof committed
219
\end{code}
220

sof's avatar
sof committed
221
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
222
223
224
%*                                                                      *
%*      Trees and forests
%*                                                                      *
sof's avatar
sof committed
225
226
227
228
229
230
231
232
%************************************************************************

\begin{code}
data Tree a   = Node a (Forest a)
type Forest a = [Tree a]

mapTree              :: (a -> b) -> (Tree a -> Tree b)
mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
233
234
235
\end{code}

\begin{code}
sof's avatar
sof committed
236
237
238
239
240
241
242
243
244
245
246
247
248
249
instance Show a => Show (Tree a) where
  showsPrec p t s = showTree t ++ s

showTree :: Show a => Tree a -> String
showTree  = drawTree . mapTree show

showForest :: Show a => Forest a -> String
showForest  = unlines . map showTree

drawTree        :: Tree String -> String
drawTree         = unlines . draw

draw (Node x ts) = grp this (space (length this)) (stLoop ts)
 where this          = s1 ++ x ++ " "
250

sof's avatar
sof committed
251
       space n       = replicate n ' '
252

sof's avatar
sof committed
253
254
255
       stLoop []     = [""]
       stLoop [t]    = grp s2 "  " (draw t)
       stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
256

sof's avatar
sof committed
257
258
       rsLoop [t]    = grp s5 "  " (draw t)
       rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
259

sof's avatar
sof committed
260
261
262
263
       grp fst rst   = zipWith (++) (fst:repeat rst)

       [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
\end{code}
264

265

sof's avatar
sof committed
266
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
267
268
269
%*                                                                      *
%*      Depth first search
%*                                                                      *
sof's avatar
sof committed
270
%************************************************************************
271

sof's avatar
sof committed
272
\begin{code}
273
type Set s    = STArray s Vertex Bool
274

sof's avatar
sof committed
275
mkEmpty      :: Bounds -> ST s (Set s)
276
mkEmpty bnds  = newArray bnds False
277

sof's avatar
sof committed
278
contains     :: Set s -> Vertex -> ST s Bool
279
contains m v  = readArray m v
280

sof's avatar
sof committed
281
include      :: Set s -> Vertex -> ST s ()
282
include m v   = writeArray m v True
sof's avatar
sof committed
283
\end{code}
284

sof's avatar
sof committed
285
286
287
288
289
290
291
292
293
294
295
\begin{code}
dff          :: Graph -> Forest Vertex
dff g         = dfs g (vertices g)

dfs          :: Graph -> [Vertex] -> Forest Vertex
dfs g vs      = prune (bounds g) (map (generate g) vs)

generate     :: Graph -> Vertex -> Tree Vertex
generate g v  = Node v (map (generate g) (g!v))

prune        :: Bounds -> Forest Vertex -> Forest Vertex
296
prune bnds ts = runST (mkEmpty bnds  >>= \m ->
sof's avatar
sof committed
297
298
299
                       chop m ts)

chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
300
chop m []     = return []
sof's avatar
sof committed
301
chop m (Node v ts : us)
302
              = contains m v >>= \visited ->
sof's avatar
sof committed
303
304
305
                if visited then
                  chop m us
                else
306
307
308
309
                  include m v >>= \_  ->
                  chop m ts   >>= \as ->
                  chop m us   >>= \bs ->
                  return (Node v as : bs)
310
\end{code}
311

sof's avatar
sof committed
312

313
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
314
315
316
%*                                                                      *
%*      Algorithms
%*                                                                      *
317
318
%************************************************************************

sof's avatar
sof committed
319
320
321
322
323
324
325
326
327
328
329
330
------------------------------------------------------------
-- Algorithm 1: depth first search numbering
------------------------------------------------------------

\begin{code}
--preorder            :: Tree a -> [a]
preorder (Node a ts) = a : preorderF ts

preorderF           :: Forest a -> [a]
preorderF ts         = concat (map preorder ts)

tabulate        :: Bounds -> [Vertex] -> Table Int
331
tabulate bnds vs = array bnds (zipWith (,) vs [1..])
sof's avatar
sof committed
332
333
334
335
336

preArr          :: Bounds -> Forest Vertex -> Table Int
preArr bnds      = tabulate bnds . preorderF
\end{code}

337

sof's avatar
sof committed
338
339
340
------------------------------------------------------------
-- Algorithm 2: topological sorting
------------------------------------------------------------
341
342

\begin{code}
343
344
postorder :: Tree a -> [a] -> [a]
postorder (Node a ts) = postorderF ts . (a :)
345

346
347
postorderF   :: Forest a -> [a] -> [a]
postorderF ts = foldr (.) id $ map postorder ts
348

349
350
postOrd :: Graph -> [Vertex]
postOrd g = postorderF (dff g) []
sof's avatar
sof committed
351

352
353
topSort :: Graph -> [Vertex]
topSort = reverse . postOrd
354
\end{code}
sof's avatar
sof committed
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415


------------------------------------------------------------
-- Algorithm 3: connected components
------------------------------------------------------------

\begin{code}
components   :: Graph -> Forest Vertex
components    = dff . undirected

undirected   :: Graph -> Graph
undirected g  = buildG (bounds g) (edges g ++ reverseE g)
\end{code}


-- Algorithm 4: strongly connected components

\begin{code}
scc  :: Graph -> Forest Vertex
scc g = dfs g (reverse (postOrd (transposeG g)))
\end{code}


------------------------------------------------------------
-- Algorithm 5: Classifying edges
------------------------------------------------------------

\begin{code}
back              :: Graph -> Table Int -> Graph
back g post        = mapT select g
 where select v ws = [ w | w <- ws, post!v < post!w ]

cross             :: Graph -> Table Int -> Table Int -> Graph
cross g pre post   = mapT select g
 where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]

forward           :: Graph -> Graph -> Table Int -> Graph
forward g tree pre = mapT select g
 where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
\end{code}


------------------------------------------------------------
-- Algorithm 6: Finding reachable vertices
------------------------------------------------------------

\begin{code}
reachable    :: Graph -> Vertex -> [Vertex]
reachable g v = preorderF (dfs g [v])

path         :: Graph -> Vertex -> Vertex -> Bool
path g v w    = w `elem` (reachable g v)
\end{code}


------------------------------------------------------------
-- Algorithm 7: Biconnected components
------------------------------------------------------------

\begin{code}
bcc :: Graph -> Forest [Vertex]
416
bcc g = (concat . map bicomps . map (do_label g dnum)) forest
sof's avatar
sof committed
417
418
419
 where forest = dff g
       dnum   = preArr (bounds g) forest

420
421
422
do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
 where us = map (do_label g dnum) ts
sof's avatar
sof committed
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
       lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
                     ++ [lu | Node (u,du,lu) xs <- us])

bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
bicomps (Node (v,dv,lv) ts)
      = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]

collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
 where collected = map collect ts
       vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
       cs = concat [ if lw<dv then us else [Node (v:ws) us]
                        | (lw, Node ws us) <- collected ]
\end{code}