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