compiler/utils/Digraph.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 %
   4
   5 \begin{code}
   6 {-# OPTIONS -w #-}
   7 -- The above warning supression flag is a temporary kludge.
   8 -- While working on this module you are encouraged to remove it and fix
   9 -- any warnings in the module. See
  10 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  11 -- for details
  12
  13 module Digraph(
  14
  15         -- At present the only one with a "nice" external interface
  16         stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
  17
  18         Graph, Vertex,
  19         graphFromEdges, graphFromEdges',
  20         buildG, transposeG, reverseE, outdegree, indegree,
  21
  22         Tree(..), Forest,
  23         showTree, showForest,
  24
  25         dfs, dff,
  26         topSort,
  27         components,
  28         scc,
  29         back, cross, forward,
  30         reachable, path,
  31         bcc
  32     ) where
  33
  34 # include "HsVersions.h"
  35
  36 ------------------------------------------------------------------------------
  37 -- A version of the graph algorithms described in:
  38 --
  39 -- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
  40 --   by David King and John Launchbury
  41 --
  42 -- Also included is some additional code for printing tree structures ...
  43 ------------------------------------------------------------------------------
  44
  45
  46 import Util        ( sortLe )
  47 import Outputable
  48
  49 -- Extensions
  50 import Control.Monad.ST
  51
  52 -- std interfaces
  53 import Data.Maybe
  54 import Data.Array
  55 import Data.List
  56
  57 #if __GLASGOW_HASKELL__ > 604
  58 import Data.Array.ST
  59 #else
  60 import Data.Array.ST  hiding ( indices, bounds )
  61 #endif
  62 \end{code}
  63
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 %*      External interface
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 \begin{code}
  72 data SCC vertex = AcyclicSCC vertex
  73                 | CyclicSCC  [vertex]
  74
  75 flattenSCCs :: [SCC a] -> [a]
  76 flattenSCCs = concatMap flattenSCC
  77
  78 flattenSCC (AcyclicSCC v) = [v]
  79 flattenSCC (CyclicSCC vs) = vs
  80
  81 instance Outputable a => Outputable (SCC a) where
  82    ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
  83    ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
  84 \end{code}
  85
  86 Note [Nodes, keys, vertices]
  87 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  88  * A 'node' is a big blob of client-stuff
  89
  90  * Each 'node' has a unique (client) 'key', but the latter
  91         is in Ord and has fast comparison
  92
  93  * Digraph then maps each 'key' to a Vertex (Int) which is
  94         arranged densely in 0.n
  95
  96 \begin{code}
  97 stronglyConnComp
  98         :: Ord key
  99         => [(node, key, [key])]         -- The graph; its ok for the
 100                                         -- out-list to contain keys which arent
 101                                         -- a vertex key, they are ignored
 102         -> [SCC node]   -- Returned in topologically sorted order
 103                         -- Later components depend on earlier ones, but not vice versa
 104
 105 stronglyConnComp edges
 106   = map get_node (stronglyConnCompR edges)
 107   where
 108     get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
 109     get_node (CyclicSCC triples)     = CyclicSCC [n | (n,_,_) <- triples]
 110
 111 -- The "R" interface is used when you expect to apply SCC to
 112 -- the (some of) the result of SCC, so you dont want to lose the dependency info
 113 stronglyConnCompR
 114         :: Ord key
 115         => [(node, key, [key])]         -- The graph; its ok for the
 116                                         -- out-list to contain keys which arent
 117                                         -- a vertex key, they are ignored
 118         -> [SCC (node, key, [key])]     -- Topologically sorted
 119
 120 stronglyConnCompR [] = []  -- added to avoid creating empty array in graphFromEdges -- SOF
 121 stronglyConnCompR edges
 122   = map decode forest
 123   where
 124     (graph, vertex_fn) = {-# SCC "graphFromEdges" #-} graphFromEdges edges
 125     forest             = {-# SCC "Digraph.scc" #-} scc graph
 126     decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
 127                        | otherwise         = AcyclicSCC (vertex_fn v)
 128     decode other = CyclicSCC (dec other [])
 129                  where
 130                    dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
 131     mentions_itself v = v `elem` (graph ! v)
 132 \end{code}
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 %*      Graphs
 137 %*                                                                      *
 138 %************************************************************************
 139
 140
 141 \begin{code}
 142 type Vertex  = Int
 143 type Table a = Array Vertex a
 144 type Graph   = Table [Vertex]
 145 type Bounds  = (Vertex, Vertex)
 146 type Edge    = (Vertex, Vertex)
 147 \end{code}
 148
 149 \begin{code}
 150 vertices :: Graph -> [Vertex]
 151 vertices  = indices
 152
 153 edges    :: Graph -> [Edge]
 154 edges g   = [ (v, w) | v <- vertices g, w <- g!v ]
 155
 156 mapT    :: (Vertex -> a -> b) -> Table a -> Table b
 157 mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ]
 158
 159 buildG :: Bounds -> [Edge] -> Graph
 160 buildG bounds edges = accumArray (flip (:)) [] bounds edges
 161
 162 transposeG  :: Graph -> Graph
 163 transposeG g = buildG (bounds g) (reverseE g)
 164
 165 reverseE    :: Graph -> [Edge]
 166 reverseE g   = [ (w, v) | (v, w) <- edges g ]
 167
 168 outdegree :: Graph -> Table Int
 169 outdegree  = mapT numEdges
 170              where numEdges v ws = length ws
 171
 172 indegree :: Graph -> Table Int
 173 indegree  = outdegree . transposeG
 174 \end{code}
 175
 176
 177 \begin{code}
 178 graphFromEdges
 179         :: Ord key
 180         => [(node, key, [key])]
 181         -> (Graph, Vertex -> (node, key, [key]))
 182 graphFromEdges edges =
 183   case graphFromEdges' edges of (graph, vertex_fn, _) -> (graph, vertex_fn)
 184
 185 graphFromEdges'
 186         :: Ord key
 187         => [(node, key, [key])]
 188         -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
 189 graphFromEdges' edges
 190   = (graph, \v -> vertex_map ! v, key_vertex)
 191   where
 192     max_v           = length edges - 1
 193     bounds          = (0,max_v) :: (Vertex, Vertex)
 194     sorted_edges    = let
 195                          (_,k1,_) `le` (_,k2,_) = case k1 `compare` k2 of { GT -> False; other -> True }
 196                       in
 197                         sortLe le edges
 198     edges1          = zipWith (,) [0..] sorted_edges
 199
 200     graph           = array bounds [ (v, mapMaybe key_vertex ks)
 201                                | (v, (_,    _, ks)) <- edges1]
 202     key_map         = array bounds [ (v, k)
 203                                | (v, (_,    k, _ )) <- edges1]
 204     vertex_map      = array bounds edges1
 205
 206
 207     -- key_vertex :: key -> Maybe Vertex
 208     --  returns Nothing for non-interesting vertices
 209     key_vertex k   = find 0 max_v
 210                    where
 211                      find a b | a > b
 212                               = Nothing
 213                      find a b = case compare k (key_map ! mid) of
 214                                    LT -> find a (mid-1)
 215                                    EQ -> Just mid
 216                                    GT -> find (mid+1) b
 217                               where
 218                                 mid = (a + b) `div` 2
 219 \end{code}
 220
 221 %************************************************************************
 222 %*                                                                      *
 223 %*      Trees and forests
 224 %*                                                                      *
 225 %************************************************************************
 226
 227 \begin{code}
 228 data Tree a   = Node a (Forest a)
 229 type Forest a = [Tree a]
 230
 231 mapTree              :: (a -> b) -> (Tree a -> Tree b)
 232 mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
 233 \end{code}
 234
 235 \begin{code}
 236 instance Show a => Show (Tree a) where
 237   showsPrec p t s = showTree t ++ s
 238
 239 showTree :: Show a => Tree a -> String
 240 showTree  = drawTree . mapTree show
 241
 242 showForest :: Show a => Forest a -> String
 243 showForest  = unlines . map showTree
 244
 245 drawTree        :: Tree String -> String
 246 drawTree         = unlines . draw
 247
 248 draw (Node x ts) = grp this (space (length this)) (stLoop ts)
 249  where this          = s1 ++ x ++ " "
 250
 251        space n       = replicate n ' '
 252
 253        stLoop []     = [""]
 254        stLoop [t]    = grp s2 "  " (draw t)
 255        stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
 256
 257        rsLoop [t]    = grp s5 "  " (draw t)
 258        rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
 259
 260        grp fst rst   = zipWith (++) (fst:repeat rst)
 261
 262        [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
 263 \end{code}
 264
 265
 266 %************************************************************************
 267 %*                                                                      *
 268 %*      Depth first search
 269 %*                                                                      *
 270 %************************************************************************
 271
 272 \begin{code}
 273 type Set s    = STArray s Vertex Bool
 274
 275 mkEmpty      :: Bounds -> ST s (Set s)
 276 mkEmpty bnds  = newArray bnds False
 277
 278 contains     :: Set s -> Vertex -> ST s Bool
 279 contains m v  = readArray m v
 280
 281 include      :: Set s -> Vertex -> ST s ()
 282 include m v   = writeArray m v True
 283 \end{code}
 284
 285 \begin{code}
 286 dff          :: Graph -> Forest Vertex
 287 dff g         = dfs g (vertices g)
 288
 289 dfs          :: Graph -> [Vertex] -> Forest Vertex
 290 dfs g vs      = prune (bounds g) (map (generate g) vs)
 291
 292 generate     :: Graph -> Vertex -> Tree Vertex
 293 generate g v  = Node v (map (generate g) (g!v))
 294
 295 prune        :: Bounds -> Forest Vertex -> Forest Vertex
 296 prune bnds ts = runST (mkEmpty bnds  >>= \m ->
 297                        chop m ts)
 298
 299 chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
 300 chop m []     = return []
 301 chop m (Node v ts : us)
 302               = contains m v >>= \visited ->
 303                 if visited then
 304                   chop m us
 305                 else
 306                   include m v >>= \_  ->
 307                   chop m ts   >>= \as ->
 308                   chop m us   >>= \bs ->
 309                   return (Node v as : bs)
 310 \end{code}
 311
 312
 313 %************************************************************************
 314 %*                                                                      *
 315 %*      Algorithms
 316 %*                                                                      *
 317 %************************************************************************
 318
 319 ------------------------------------------------------------
 320 -- Algorithm 1: depth first search numbering
 321 ------------------------------------------------------------
 322
 323 \begin{code}
 324 --preorder            :: Tree a -> [a]
 325 preorder (Node a ts) = a : preorderF ts
 326
 327 preorderF           :: Forest a -> [a]
 328 preorderF ts         = concat (map preorder ts)
 329
 330 tabulate        :: Bounds -> [Vertex] -> Table Int
 331 tabulate bnds vs = array bnds (zipWith (,) vs [1..])
 332
 333 preArr          :: Bounds -> Forest Vertex -> Table Int
 334 preArr bnds      = tabulate bnds . preorderF
 335 \end{code}
 336
 337
 338 ------------------------------------------------------------
 339 -- Algorithm 2: topological sorting
 340 ------------------------------------------------------------
 341
 342 \begin{code}
 343 postorder :: Tree a -> [a] -> [a]
 344 postorder (Node a ts) = postorderF ts . (a :)
 345
 346 postorderF   :: Forest a -> [a] -> [a]
 347 postorderF ts = foldr (.) id $ map postorder ts
 348
 349 postOrd :: Graph -> [Vertex]
 350 postOrd g = postorderF (dff g) []
 351
 352 topSort :: Graph -> [Vertex]
 353 topSort = reverse . postOrd
 354 \end{code}
 355
 356
 357 ------------------------------------------------------------
 358 -- Algorithm 3: connected components
 359 ------------------------------------------------------------
 360
 361 \begin{code}
 362 components   :: Graph -> Forest Vertex
 363 components    = dff . undirected
 364
 365 undirected   :: Graph -> Graph
 366 undirected g  = buildG (bounds g) (edges g ++ reverseE g)
 367 \end{code}
 368
 369
 370 -- Algorithm 4: strongly connected components
 371
 372 \begin{code}
 373 scc  :: Graph -> Forest Vertex
 374 scc g = dfs g (reverse (postOrd (transposeG g)))
 375 \end{code}
 376
 377
 378 ------------------------------------------------------------
 379 -- Algorithm 5: Classifying edges
 380 ------------------------------------------------------------
 381
 382 \begin{code}
 383 back              :: Graph -> Table Int -> Graph
 384 back g post        = mapT select g
 385  where select v ws = [ w | w <- ws, post!v < post!w ]
 386
 387 cross             :: Graph -> Table Int -> Table Int -> Graph
 388 cross g pre post   = mapT select g
 389  where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
 390
 391 forward           :: Graph -> Graph -> Table Int -> Graph
 392 forward g tree pre = mapT select g
 393  where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
 394 \end{code}
 395
 396
 397 ------------------------------------------------------------
 398 -- Algorithm 6: Finding reachable vertices
 399 ------------------------------------------------------------
 400
 401 \begin{code}
 402 reachable    :: Graph -> Vertex -> [Vertex]
 403 reachable g v = preorderF (dfs g [v])
 404
 405 path         :: Graph -> Vertex -> Vertex -> Bool
 406 path g v w    = w `elem` (reachable g v)
 407 \end{code}
 408
 409
 410 ------------------------------------------------------------
 411 -- Algorithm 7: Biconnected components
 412 ------------------------------------------------------------
 413
 414 \begin{code}
 415 bcc :: Graph -> Forest [Vertex]
 416 bcc g = (concat . map bicomps . map (do_label g dnum)) forest
 417  where forest = dff g
 418        dnum   = preArr (bounds g) forest
 419
 420 do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
 421 do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
 422  where us = map (do_label g dnum) ts
 423        lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
 424                      ++ [lu | Node (u,du,lu) xs <- us])
 425
 426 bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
 427 bicomps (Node (v,dv,lv) ts)
 428       = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
 429
 430 collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
 431 collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
 432  where collected = map collect ts
 433        vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
 434        cs = concat [ if lw<dv then us else [Node (v:ws) us]
 435                         | (lw, Node ws us) <- collected ]
 436 \end{code}
 437