ghc/compiler/utils/Digraph.lhs

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