home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / hugs_1 / demos_hs_Ldfs < prev    next >
Encoding:
Text File  |  1996-08-12  |  7.2 KB  |  248 lines
  1. ------------------------------------------------------------------------------
  2. -- A version of the graph algorithms described in:
  3. -- 
  4. -- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
  5. --   by David King and John Launchbury
  6. -- 
  7. -- Also included is some additional code for printing tree structures ...
  8. --
  9. -- Suitable for use with Hugs 1.3.
  10. ------------------------------------------------------------------------------
  11.  
  12. import Array
  13. import List
  14. import ST
  15. import STArray
  16.  
  17. type Vertex  = Char
  18.  
  19. -- Representing graphs:
  20.  
  21. type Table a = Array Vertex a
  22. type Graph   = Table [Vertex]
  23.  
  24. vertices :: Graph -> [Vertex]
  25. vertices  = indices
  26.  
  27. type Edge = (Vertex, Vertex)
  28.  
  29. edges    :: Graph -> [Edge]
  30. edges g   = [ (v, w) | v <- vertices g, w <- g!v ]
  31.  
  32. mapT    :: (Vertex -> a -> b) -> Table a -> Table b
  33. mapT f t = array (bounds t) [ (v, f v (t!v)) | v <- indices t ]
  34.  
  35. type Bounds = (Vertex, Vertex)
  36.  
  37. outdegree :: Graph -> Table Int
  38. outdegree  = mapT numEdges
  39.              where numEdges v ws = length ws
  40.  
  41. buildG :: Bounds -> [Edge] -> Graph
  42. buildG  = accumArray (flip (:)) []
  43.  
  44. graph = buildG ('a','j')
  45.          (reverse
  46.           [ ('a', 'b'),  ('a', 'f'),  ('b', 'c'),
  47.             ('b', 'e'),  ('c', 'a'),  ('c', 'd'),
  48.             ('e', 'd'),  ('g', 'h'),  ('g', 'j'),
  49.             ('h', 'f'),  ('h', 'i'),  ('h', 'j') ]
  50.          )
  51.  
  52. transposeG  :: Graph -> Graph
  53. transposeG g = buildG (bounds g) (reverseE g)
  54.  
  55. reverseE    :: Graph -> [Edge]
  56. reverseE g   = [ (w, v) | (v, w) <- edges g ]
  57.  
  58. indegree :: Graph -> Table Int
  59. indegree  = outdegree . transposeG
  60.  
  61.  
  62. -- Depth-first search
  63.  
  64. -- Specification and implementation of depth-first search:
  65.  
  66. data Tree a   = Node a (Forest a) deriving Show
  67. type Forest a = [Tree a]
  68.  
  69. dff          :: Graph -> Forest Vertex
  70. dff g         = dfs g (vertices g)
  71.  
  72. dfs          :: Graph -> [Vertex] -> Forest Vertex
  73. dfs g vs      = prune (bounds g) (map (generate g) vs)
  74.  
  75. generate     :: Graph -> Vertex -> Tree Vertex
  76. generate g v  = Node v (map (generate g) (g!v))
  77.  
  78. type Set s    = MutArr s Vertex Bool
  79.  
  80. mkEmpty      :: Bounds -> ST s (Set s)
  81. mkEmpty bnds  = newArr bnds False
  82.  
  83. contains     :: Set s -> Vertex -> ST s Bool
  84. contains m v  = readArr m v
  85.  
  86. include      :: Set s -> Vertex -> ST s ()
  87. include m v   = writeArr m v True
  88.  
  89. prune        :: Bounds -> Forest Vertex -> Forest Vertex
  90. prune bnds ts = runST (mkEmpty bnds  `thenST` \m ->
  91.                        chop m ts)
  92.  
  93. chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
  94. chop m []     = returnST []
  95. chop m (Node v ts : us)
  96.               = contains m v `thenST` \visited ->
  97.                 if visited then
  98.                   chop m us
  99.                 else
  100.                   include m v `thenST` \_  ->
  101.                   chop m ts   `thenST` \as ->
  102.                   chop m us   `thenST` \bs ->
  103.                   returnST (Node v as : bs)
  104.  
  105. -- Depth-first search algorithms
  106.  
  107. -- Algorithm 1: depth first search numbering
  108.  
  109. preorder            :: Tree a -> [a]
  110. preorder (Node a ts) = [a] ++ preorderF ts
  111.  
  112. preorderF           :: Forest a -> [a]
  113. preorderF ts         = concat (map preorder ts)
  114.  
  115. preOrd :: Graph -> [Vertex]
  116. preOrd  = preorderF . dff
  117.  
  118. tabulate        :: Bounds -> [Vertex] -> Table Int
  119. tabulate bnds vs = array bnds (zip vs [1..])
  120.  
  121. preArr          :: Bounds -> Forest Vertex -> Table Int
  122. preArr bnds      = tabulate bnds . preorderF
  123.  
  124. -- Algorithm 2: topological sorting
  125.  
  126. postorder :: Tree a -> [a]
  127. postorder (Node a ts) = postorderF ts ++ [a]
  128.  
  129. postorderF   :: Forest a -> [a]
  130. postorderF ts = concat (map postorder ts)
  131.  
  132. postOrd      :: Graph -> [Vertex]
  133. postOrd       = postorderF . dff
  134.  
  135. topSort      :: Graph -> [Vertex]
  136. topSort       = reverse . postOrd
  137.  
  138. -- Algorithm 3: connected components
  139.  
  140. components   :: Graph -> Forest Vertex
  141. components    = dff . undirected
  142.  
  143. undirected   :: Graph -> Graph
  144. undirected g  = buildG (bounds g) (edges g ++ reverseE g)
  145.  
  146. -- Algorithm 4: strongly connected components
  147.  
  148. scc          :: Graph -> Forest Vertex
  149. scc g         = dfs (transposeG g) (reverse (postOrd g))
  150.  
  151. scc'         :: Graph -> Forest Vertex
  152. scc' g        = dfs g (reverse (postOrd (transposeG g)))
  153.  
  154. -- Algorithm 5: Classifying edges
  155.  
  156. tree              :: Bounds -> Forest Vertex -> Graph
  157. tree bnds ts       = buildG bnds (concat (map flat ts))
  158.  where flat (Node v rs) = [ (v, w) | Node w us <- ts ] ++
  159.                           concat (map flat ts)
  160.  
  161. back              :: Graph -> Table Int -> Graph
  162. back g post        = mapT select g
  163.  where select v ws = [ w | w <- ws, post!v < post!w ]
  164.  
  165. cross             :: Graph -> Table Int -> Table Int -> Graph
  166. cross g pre post   = mapT select g
  167.  where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
  168.  
  169. forward           :: Graph -> Graph -> Table Int -> Graph
  170. forward g tree pre = mapT select g
  171.  where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
  172.  
  173. -- Algorithm 6: Finding reachable vertices
  174.  
  175. reachable    :: Graph -> Vertex -> [Vertex]
  176. reachable g v = preorderF (dfs g [v])
  177.  
  178. path         :: Graph -> Vertex -> Vertex -> Bool
  179. path g v w    = w `elem` (reachable g v)
  180.  
  181. -- Algorithm 7: Biconnected components
  182.  
  183. bcc :: Graph -> Forest [Vertex]
  184. bcc g = (concat . map bicomps . map (label g dnum)) forest
  185.  where forest = dff g
  186.        dnum   = preArr (bounds g) forest
  187.  
  188. label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
  189. label g dnum (Node v ts) = Node (v,dnum!v,lv) us
  190.  where us = map (label g dnum) ts
  191.        lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
  192.                      ++ [lu | Node (u,du,lu) xs <- us])
  193.  
  194. bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
  195. bicomps (Node (v,dv,lv) ts)
  196.       = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
  197.  
  198. collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
  199. collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
  200.  where collected = map collect ts
  201.        vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
  202.        cs = concat [ if lw<dv then us else [Node (v:ws) us]
  203.                         | (lw, Node ws us) <- collected ]
  204.  
  205. figure4 = buildG ('a','i') (vs ++ reverse [ (v, w) | (w, v) <- vs ])
  206.           where vs = [ ('b', 'a'), ('e', 'a'), ('c', 'b'),
  207.                        ('d', 'c'), ('b', 'd'), ('f', 'e'),
  208.                        ('h', 'e'), ('g', 'f'), ('e', 'g'),
  209.                        ('i', 'h'), ('a', 'i'), ('h', 'a') ]
  210.  
  211. figure5 = showForest (map (label figure4 dnum) f)
  212.           where f    = dff figure4
  213.                 dnum = preArr (bounds figure4) f
  214.  
  215. figure7 = showForest (bcc figure4)
  216.  
  217. -- Utility functions for drawing trees and forests:
  218.  
  219. showTree :: Show a => Tree a -> String
  220. showTree  = drawTree . mapTree show
  221.  
  222. showForest :: Show a => Forest a -> String
  223. showForest  = unlines . map showTree
  224.  
  225. mapTree              :: (a -> b) -> (Tree a -> Tree b)
  226. mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
  227.  
  228. drawTree        :: Tree String -> String
  229. drawTree         = unlines . draw
  230.  
  231. draw (Node x ts) = grp this (space (length this)) (stLoop ts)
  232.  where this          = s1 ++ x ++ " "
  233.  
  234.        space n       = take n (repeat ' ')
  235.  
  236.        stLoop []     = [""]
  237.        stLoop [t]    = grp s2 "  " (draw t)
  238.        stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
  239.  
  240.        rsLoop [t]    = grp s5 "  " (draw t)
  241.        rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
  242.  
  243.        grp fst rst   = zipWith (++) (fst:repeat rst)
  244.  
  245.        [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
  246.  
  247. ------------------------------------------------------------------------------
  248.