home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 2 / DATAFILE_PDCD2.iso / utilities / _gofer / !Gofer / archives / Demos / Cse / gs / csexpr next >
Text File  |  1993-02-12  |  11KB  |  379 lines
  1. -- This is a program to illustrate a simple form of common subexpression
  2. -- elimination ... essentially turning trees into DAGs.  Uses two state
  3. -- monads (more precisely, same monad but different state types).
  4. -- This program doesn't use constructor classes, although it could
  5. -- obviously be modified to fit into that framework.
  6. --
  7. -- This programs should be loaded after `stateMonad':  For example:
  8. --  ? :l stateMonad.gs csexpr.gs
  9. --  ? test
  10. --
  11. -- The output for this `test' is included at the end of the file.
  12. --
  13. -- Mark P. Jones, 1992
  14. --
  15.  
  16. -- Data type definitions: ----------------------------------------------------
  17.  
  18. data GenTree a  = Node a [GenTree a]
  19. type LabGraph a = [ (Label, a, [Label]) ]
  20. type Label      = Int
  21.  
  22. -- Add distinct (integer) labels to each node of a tree: ---------------------
  23.  
  24. labelTree   :: GenTree a -> GenTree (Label,a)
  25. labelTree t  = label t `startingWith` 0
  26.                where label (Node x xs) = incr           `bind` \n  ->
  27.                                          mmapl label xs `bind` \ts ->
  28.                                          return (Node (n,x) ts)
  29.  
  30. -- Convert tree after labelling each node to a labelled graph: ---------------
  31.  
  32. ltGraph                :: GenTree (Label,a) -> LabGraph a
  33. ltGraph (Node (n,x) xs) = (n, x, map labelOf xs) : concat (map ltGraph xs)
  34.                           where labelOf (Node (n,x) xs) = n
  35.  
  36. -- Build tree from labelled graph: -------------------------------------------
  37.  
  38. unGraph              :: LabGraph a -> GenTree a
  39. unGraph ((n,x,cs):ts) = Node x (map (unGraph . find) cs)
  40.                         where find c = dropWhile (\(d,_,_) -> c/=d) ts
  41.  
  42.  
  43. -- Build tree but avoid duplicating shared parts: ----------------------------
  44.  
  45. unGraph'     :: LabGraph String -> GenTree (Int,String)
  46. unGraph' lg   = ung lg `startingWith` []
  47.  where ung ((n,x,cs):ts) = mif (visited n)
  48.                                  (return (Node (n,"<>") []))
  49.                                  (mmapl (ung . find) cs `bind` \ts ->
  50.                                   return (Node (n,x) ts))
  51.                            where find c = dropWhile (\(d,_,_) -> c/=d) ts
  52.  
  53. visited      :: Label -> SM [Label] Bool
  54. visited n     = fetch                               `bind` \us ->
  55.                 if n `elem` us then return True
  56.                                else set (n:us)      `bind` \_ -> 
  57.                                     return False
  58.  
  59. -- Find (and eliminate) repeated subtrees in a labelled graph: ---------------
  60. -- Described as a transformation on labelled graphs:  During the calculation
  61. -- we use a pair (r,lg) :: (Label->Label, LabGraph a) where lg contains the
  62. -- simplified portion of the graph calculated so far and r is a renaming (or
  63. -- replacement?) which maps node labels in the original graph to the approp.
  64. -- labels in the new graph.
  65.  
  66. findCommon :: Eq a => LabGraph a -> LabGraph a
  67. findCommon  = snd . foldr sim (id,[])
  68.  where sim (n,s,cs) (r,lg) = (r, [(n,s,rcs)]++lg),       if null ms
  69.                            = ((n +-> head ms) r, lg),    otherwise
  70.                              where ms  = [m | (m,s',cs')<-lg, s==s', cs'==rcs]
  71.                                    rcs = map r cs
  72.  
  73. infix +->      -- overide function at single point
  74. (+->)          :: Eq a => a -> b -> (a -> b) -> (a -> b)
  75. (x +-> fx) f y  = if x==y then fx else f y
  76.  
  77. -- Common subexpression elimination: -----------------------------------------
  78.  
  79. cse :: Eq a => GenTree a -> LabGraph a
  80. cse  = findCommon . ltGraph . labelTree
  81.  
  82. -- Pretty printers: ----------------------------------------------------------
  83.  
  84. instance Text (GenTree String) where
  85.     showsPrec d (Node x ts)
  86.         | null ts   = showString x
  87.         | otherwise = showChar '(' . showString x
  88.                                    . showChar ' '
  89.                                    . (foldr1 (\x y -> x . showChar ' ' . y)
  90.                                              (map shows ts))
  91.                                    . showChar ')'
  92.  
  93. drawTree        :: GenTree String -> String
  94. drawTree         = unlines . draw
  95. draw (Node x ts) = grp (s1 ++ pad width x ++ "]") (space (width+3)) (stLoop ts)
  96.  where stLoop []     = [""]
  97.        stLoop [t]    = grp s2 "  " (draw t)
  98.        stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
  99.  
  100.        rsLoop [t]    = grp s5 "  " (draw t)
  101.        rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
  102.  
  103.        grp fst rst   = zipWith (++) (fst:repeat rst)
  104.  
  105.        -- Define the strings used to print tree diagrams:
  106.        [s1,s2,s3,s4,s5,s6] | pcGraphics = ["\196[", "\196\196", "\196\194",
  107.                                            " \179", " \192",    " \195"]
  108.                            | otherwise  = ["-[",    "--",       "-+",
  109.                                            " |",    " `",       " +"]
  110.  
  111.        pad n x    = take n (x ++ repeat ' ')
  112.        width      = 4
  113.        pcGraphics = False
  114.  
  115. showGraph   :: LabGraph a -> String
  116. showGraph [] = "[]\n"
  117. showGraph xs = "[" ++ loop (map show' xs)
  118.                where loop [x]    = x ++ "]\n"
  119.                      loop (x:xs) = x ++ ",\n " ++ loop xs
  120.  
  121. -- Examples: -----------------------------------------------------------------
  122.  
  123. plus x y = Node "+" [x,y]
  124. mult x y = Node "*" [x,y]
  125. prod xs  = Node "X" xs
  126. zero     = Node "0" []
  127. a        = Node "a" []
  128. b        = Node "b" []
  129. c        = Node "c" []
  130. d        = Node "d" []
  131.  
  132. examples = [example0, example1, example2, example3, example4, example5]
  133. example0 = a
  134. example1 = plus a a
  135. example2 = plus (mult a b) (mult a b)
  136. example3 = plus (mult (plus a b) c) (plus a b)
  137. example4 = prod (scanl plus zero [a,b,c,d])
  138. example5 = prod (scanr plus zero [a,b,c,d])
  139.  
  140. test  = appendChan "stdout" -- writeFile "csoutput"
  141.          (unlines (map (\t -> let c = cse t
  142.                               in  copy 78 '-'            ++
  143.                                   "\nExpression:\n"      ++ show t      ++
  144.                                   "\n\nTree:\n"          ++ drawTree t  ++
  145.                                   "\nLabelled graph:\n"  ++ showGraph c ++
  146.                                   "\nSimplified tree:\n" ++ showCse c)
  147.                        examples))
  148.          exit
  149.          done
  150.         where
  151.          showCse                  = drawTree
  152.                                     . mapGenTree (\(n,s) -> show n++":"++s)
  153.                                     . unGraph'
  154.          mapGenTree f (Node x ts) = Node (f x) (map (mapGenTree f) ts)
  155.  
  156. {-----------------------------------------------------------------------------
  157. Expression:
  158. a
  159.  
  160. Tree:
  161. -[a   ]
  162.  
  163. Labelled graph:
  164. [(0,"a",[])]
  165.  
  166. Simplified tree:
  167. -[0:a ]
  168.  
  169. ------------------------------------------------------------------------------
  170. Expression:
  171. (+ a a)
  172.  
  173. Tree:
  174. -[+   ]-+-[a   ]
  175.         |
  176.         `-[a   ]
  177.  
  178. Labelled graph:
  179. [(0,"+",[2, 2]),
  180.  (2,"a",[])]
  181.  
  182. Simplified tree:
  183. -[0:+ ]-+-[2:a ]
  184.         |
  185.         `-[2:<>]
  186.  
  187. ------------------------------------------------------------------------------
  188. Expression:
  189. (+ (* a b) (* a b))
  190.  
  191. Tree:
  192. -[+   ]-+-[*   ]-+-[a   ]
  193.         |        |
  194.         |        `-[b   ]
  195.         |
  196.         `-[*   ]-+-[a   ]
  197.                  |
  198.                  `-[b   ]
  199.  
  200. Labelled graph:
  201. [(0,"+",[4, 4]),
  202.  (4,"*",[5, 6]),
  203.  (5,"a",[]),
  204.  (6,"b",[])]
  205.  
  206. Simplified tree:
  207. -[0:+ ]-+-[4:* ]-+-[5:a ]
  208.         |        |
  209.         |        `-[6:b ]
  210.         |
  211.         `-[4:<>]
  212.  
  213. ------------------------------------------------------------------------------
  214. Expression:
  215. (+ (* (+ a b) c) (+ a b))
  216.  
  217. Tree:
  218. -[+   ]-+-[*   ]-+-[+   ]-+-[a   ]
  219.         |        |        |
  220.         |        |        `-[b   ]
  221.         |        |
  222.         |        `-[c   ]
  223.         |
  224.         `-[+   ]-+-[a   ]
  225.                  |
  226.                  `-[b   ]
  227.  
  228. Labelled graph:
  229. [(0,"+",[1, 6]),
  230.  (1,"*",[6, 5]),
  231.  (5,"c",[]),
  232.  (6,"+",[7, 8]),
  233.  (7,"a",[]),
  234.  (8,"b",[])]
  235.  
  236. Simplified tree:
  237. -[0:+ ]-+-[1:* ]-+-[6:+ ]-+-[7:a ]
  238.         |        |        |
  239.         |        |        `-[8:b ]
  240.         |        |
  241.         |        `-[5:c ]
  242.         |
  243.         `-[6:<>]
  244.  
  245. ------------------------------------------------------------------------------
  246. Expression:
  247. (X 0 (+ 0 a) (+ (+ 0 a) b) (+ (+ (+ 0 a) b) c) (+ (+ (+ (+ 0 a) b) c) d))
  248.  
  249. Tree:
  250. -[X   ]-+-[0   ]
  251.         |
  252.         +-[+   ]-+-[0   ]
  253.         |        |
  254.         |        `-[a   ]
  255.         |
  256.         +-[+   ]-+-[+   ]-+-