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