home *** CD-ROM | disk | FTP | other *** search
/ back2roots/padua / padua.7z / padua / lang / gofer223.lha / demos / csexpr < prev    next >
Encoding:
Text File  |  1992-08-14  |  10.8 KB  |  377 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. --
  5. -- This programs should be loaded after `stateMonad':  For example:
  6. --  ? :l stateMonad csexpr
  7. --  ? test
  8. --
  9. -- The output for this `test' is included at the end of the file.
  10. --
  11. -- Mark P. Jones, 1992
  12. --
  13.  
  14. -- Data type definitions: ----------------------------------------------------
  15.  
  16. data GenTree a  = Node a [GenTree a]
  17. type LabGraph a = [ (Label, a, [Label]) ]
  18. type Label      = Int
  19.  
  20. -- Add distinct (integer) labels to each node of a tree: ---------------------
  21.  
  22. labelTree   :: GenTree a -> GenTree (Label,a)
  23. labelTree t  = label t `startingWith` 0
  24.                where label (Node x xs) = incr           `bind` \n  ->
  25.                                          mmapl label xs `bind` \ts ->
  26.                                          return (Node (n,x) ts)
  27.  
  28. -- Convert tree after labelling each node to a labelled graph: ---------------
  29.  
  30. ltGraph                :: GenTree (Label,a) -> LabGraph a
  31. ltGraph (Node (n,x) xs) = (n, x, map labelOf xs) : concat (map ltGraph xs)
  32.                           where labelOf (Node (n,x) xs) = n
  33.  
  34. -- Build tree from labelled graph: -------------------------------------------
  35.  
  36. unGraph              :: LabGraph a -> GenTree a
  37. unGraph ((n,x,cs):ts) = Node x (map (unGraph . find) cs)
  38.                         where find c = dropWhile (\(d,_,_) -> c/=d) ts
  39.  
  40.  
  41. -- Build tree but avoid duplicating shared parts: ----------------------------
  42.  
  43. unGraph'     :: LabGraph String -> GenTree (Int,String)
  44. unGraph' lg   = ung lg `startingWith` []
  45.  where ung ((n,x,cs):ts) = mif (visited n)
  46.                                  (return (Node (n,"<>") []))
  47.                                  (mmapl (ung . find) cs `bind` \ts ->
  48.                                   return (Node (n,x) ts))
  49.                            where find c = dropWhile (\(d,_,_) -> c/=d) ts
  50.  
  51. visited      :: Label -> SM [Label] Bool
  52. visited n     = fetch                               `bind` \us ->
  53.                 if n `elem` us then return True
  54.                                else set (n:us)      `bind` \_ -> 
  55.                                     return False
  56.  
  57. -- Find (and eliminate) repeated subtrees in a labelled graph: ---------------
  58. -- Described as a transformation on labelled graphs:  During the calculation
  59. -- we use a pair (r,lg) :: (Label->Label, LabGraph a) where lg contains the
  60. -- simplified portion of the graph calculated so far and r is a renaming (or
  61. -- replacement?) which maps node labels in the original graph to the approp.
  62. -- labels in the new graph.
  63.  
  64. findCommon :: Eq a => LabGraph a -> LabGraph a
  65. findCommon  = snd . foldr sim (id,[])
  66.  where sim (n,s,cs) (r,lg) = (r, [(n,s,rcs)]++lg),       if null ms
  67.                            = ((n +-> head ms) r, lg),    otherwise
  68.                              where ms  = [m | (m,s',cs')<-lg, s==s', cs'==rcs]
  69.                                    rcs = map r cs
  70.  
  71. infix +->      -- overide function at single point
  72. (+->)          :: Eq a => a -> b -> (a -> b) -> (a -> b)
  73. (x +-> fx) f y  = if x==y then fx else f y
  74.  
  75. -- Common subexpression elimination: -----------------------------------------
  76.  
  77. cse :: Eq a => GenTree a -> LabGraph a
  78. cse  = findCommon . ltGraph . labelTree
  79.  
  80. -- Pretty printers: ----------------------------------------------------------
  81.  
  82. instance Text (GenTree String) where
  83.     showsPrec d (Node x ts)
  84.         | null ts   = showString x
  85.         | otherwise = showChar '(' . showString x
  86.                                    . showChar ' '
  87.                                    . (foldr1 (\x y -> x . showChar ' ' . y)
  88.                                              (map shows ts))
  89.                                    . showChar ')'
  90.  
  91. drawTree        :: GenTree String -> String
  92. drawTree         = unlines . draw
  93. draw (Node x ts) = grp (s1 ++ pad width x ++ "]") (space (width+3)) (stLoop ts)
  94.  where stLoop []     = [""]
  95.        stLoop [t]    = grp s2 "  " (draw t)
  96.        stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
  97.  
  98.        rsLoop [t]    = grp s5 "  " (draw t)
  99.        rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
  100.  
  101.        grp fst rst   = zipWith (++) (fst:repeat rst)
  102.  
  103.        -- Define the strings used to print tree diagrams:
  104.        [s1,s2,s3,s4,s5,s6] | pcGraphics = ["\196[", "\196\196", "\196\194",
  105.                                            " \179", " \192",    " \195"]
  106.                            | otherwise  = ["-[",    "--",       "-+",
  107.                                            " |",    " `",       " +"]
  108.  
  109.        pad n x    = take n (x ++ repeat ' ')
  110.        width      = 4
  111.        pcGraphics = False
  112.  
  113. showGraph   :: LabGraph a -> String
  114. showGraph [] = "[]\n"
  115. showGraph xs = "[" ++ loop (map show' xs)
  116.                where loop [x]    = x ++ "]\n"
  117.                      loop (x:xs) = x ++ ",\n " ++ loop xs
  118.  
  119. -- Examples: -----------------------------------------------------------------
  120.  
  121. plus x y = Node "+" [x,y]
  122. mult x y = Node "*" [x,y]
  123. prod xs  = Node "X" xs
  124. zero     = Node "0" []
  125. a        = Node "a" []
  126. b        = Node "b" []
  127. c        = Node "c" []
  128. d        = Node "d" []
  129.  
  130. examples = [example0, example1, example2, example3, example4, example5]
  131. example0 = a
  132. example1 = plus a a
  133. example2 = plus (mult a b) (mult a b)
  134. example3 = plus (mult (plus a b) c) (plus a b)
  135. example4 = prod (scanl plus zero [a,b,c,d])
  136. example5 = prod (scanr plus zero [a,b,c,d])
  137.  
  138. test  = appendChan "stdout" -- writeFile "csoutput"
  139.          (unlines (map (\t -> let c = cse t
  140.                               in  copy 78 '-'            ++
  141.                                   "\nExpression:\n"      ++ show t      ++
  142.                                   "\n\nTree:\n"          ++ drawTree t  ++
  143.                                   "\nLabelled graph:\n"  ++ showGraph c ++
  144.                                   "\nSimplified tree:\n" ++ showCse c)
  145.                        examples))
  146.          exit
  147.          done
  148.         where
  149.          showCse                  = drawTree
  150.                                     . mapGenTree (\(n,s) -> show n++":"++s)
  151.                                     . unGraph'
  152.          mapGenTree f (Node x ts) = Node (f x) (map (mapGenTree f) ts)
  153.  
  154. {-----------------------------------------------------------------------------
  155. Expression:
  156. a
  157.  
  158. Tree:
  159. -[a   ]
  160.  
  161. Labelled graph:
  162. [(0,"a",[])]
  163.  
  164. Simplified tree:
  165. -[0:a ]
  166.  
  167. ------------------------------------------------------------------------------
  168. Expression:
  169. (+ a a)
  170.  
  171. Tree:
  172. -[+   ]-+-[a   ]
  173.         |
  174.         `-[a   ]
  175.  
  176. Labelled graph:
  177. [(0,"+",[2, 2]),
  178.  (2,"a",[])]
  179.  
  180. Simplified tree:
  181. -[0:+ ]-+-[2:a ]
  182.         |
  183.         `-[2:<>]
  184.  
  185. ------------------------------------------------------------------------------
  186. Expression:
  187. (+ (* a b) (* a b))
  188.  
  189. Tree:
  190. -[+   ]-+-[*   ]-+-[a   ]
  191.         |        |
  192.         |        `-[b   ]
  193.         |
  194.         `-[*   ]-+-[a   ]
  195.                  |
  196.                  `-[b   ]
  197.  
  198. Labelled graph:
  199. [(0,"+",[4, 4]),
  200.  (4,"*",[5, 6]),
  201.  (5,"a",[]),
  202.  (6,"b",[])]
  203.  
  204. Simplified tree:
  205. -[0:+ ]-+-[4:* ]-+-[5:a ]
  206.         |        |
  207.         |        `-[6:b ]
  208.         |
  209.         `-[4:<>]
  210.  
  211. ------------------------------------------------------------------------------
  212. Expression:
  213. (+ (* (+ a b) c) (+ a b))
  214.  
  215. Tree:
  216. -[+   ]-+-[*   ]-+-[+   ]-+-[a   ]
  217.         |        |        |
  218.         |        |        `-[b   ]
  219.         |        |
  220.         |        `-[c   ]
  221.         |
  222.         `-[+   ]-+-[a   ]
  223.                  |
  224.                  `-[b   ]
  225.  
  226. Labelled graph:
  227. [(0,"+",[1, 6]),
  228.  (1,"*",[6, 5]),
  229.  (5,"c",[]),
  230.  (6,"+",[7, 8]),
  231.  (7,"a",[]),
  232.  (8,"b",[])]
  233.  
  234. Simplified tree:
  235. -[0:+ ]-+-[1:* ]-+-[6:+ ]-+-[7:a ]
  236.         |        |        |
  237.         |        |        `-[8:b ]
  238.         |        |
  239.         |        `-[5:c ]
  240.         |
  241.         `-[6:<>]
  242.  
  243. ------------------------------------------------------------------------------
  244. Expression:
  245. (X 0 (+ 0 a) (+ (+ 0 a) b) (+ (+ (+ 0 a) b) c) (+ (+ (+ (+ 0 a) b) c) d))
  246.  
  247. Tree:
  248. -[X   ]-+-[0   ]
  249.         |
  250.         +-[+   ]-+-[0   ]
  251.         |        |
  252.         |        `-[a   ]
  253.         |
  254.         +-[+   ]-+-[+   ]-+-[0   ]
  255.         |        |        |
  256.         |        |        `-[a   ]
  257.         |        |
  258.         |        `-[b   ]
  259.         |
  260.         +-[+   ]-+-[+   ]-+-[+   ]-+-[0   ]
  261.         |        |        |        |
  262.         |        |        |        `-[a   ]
  263.         |        |        |
  264.         |        |        `-[b   ]
  265.         |        |
  266.         |        `-[c   ]
  267.         |
  268.         `-[+   ]-+-[+   ]-+-[+   ]-+-[+   ]-+-[0   ]
  269.                  |        |        |        |
  270.                  |        |        |        `-[a   ]
  271.                  |        |        |
  272.                  |        |        `-[b   ]
  273.                  |        |
  274.                  |        `-[c   ]
  275.                  |
  276.                  `-[d   ]
  277.  
  278. Labelled graph:
  279. [(0,"X",[21, 20, 19, 18, 17]),
  280.  (17,"+",[18, 25]),
  281.  (18,"+",[19, 24]),
  282.  (19,"+",[20, 23]),
  283.  (20,"+",[21, 22]),
  284.  (21,"0",[]),
  285.  (22,"a",[]),
  286.  (23,"b",[]),
  287.  (24,"c",[]),
  288.  (25,"d",[])]
  289.  
  290. Simplified tree:
  291. -[0:X ]-+-[21:0]
  292.         |
  293.         +-[20:+]-+-[21:<]
  294.         |        |
  295.         |        `-[22:a]
  296.         |
  297.         +-[19:+]-+-[20:<]
  298.         |        |
  299.         |        `-[23:b]
  300.         |
  301.         +-[18:+]-+-[19:<]
  302.         |        |
  303.         |        `-[24:c]
  304.         |
  305.         `-[17:+]-+-[18:<]
  306.                  |
  307.                  `-[25:d]
  308.  
  309.  
  310. ------------------------------------------------------------------------------
  311. Expression:
  312. (X (+ a (+ b (+ c (+ d 0)))) (+ b (+ c (+ d 0))) (+ c (+ d 0)) (+ d 0) 0)
  313.  
  314. Tree:
  315. -[X   ]-+-[+   ]-+-[a   ]
  316.         |        |
  317.         |        `-[+   ]-+-[b   ]
  318.         |                 |
  319.         |                 `-[+   ]-+-[c   ]
  320.         |                          |
  321.         |                          `-[+   ]-+-[d   ]
  322.         |                                   |
  323.         |                                   `-[0   ]
  324.         |
  325.         +-[+   ]-+-[b   ]
  326.         |        |
  327.         |        `-[+   ]-+-[c   ]
  328.         |                 |
  329.         |                 `-[+   ]-+-[d   ]
  330.         |                          |
  331.         |                          `-[0   ]
  332.         |
  333.         +-[+   ]-+-[c   ]
  334.         |        |
  335.         |        `-[+   ]-+-[d   ]
  336.         |                 |
  337.         |                 `-[0   ]
  338.         |
  339.         +-[+   ]-+-[d   ]
  340.         |        |
  341.         |        `-[0   ]
  342.         |
  343.         `-[0   ]
  344.  
  345. Labelled graph:
  346. [(0,"X",[1, 10, 17, 22, 25]),
  347.  (1,"+",[2, 10]),
  348.  (2,"a",[]),
  349.  (10,"+",[11, 17]),
  350.  (11,"b",[]),
  351.  (17,"+",[18, 22]),
  352.  (18,"c",[]),
  353.  (22,"+",[23, 25]),
  354.  (23,"d",[]),
  355.  (25,"0",[])]
  356.  
  357. Simplified tree:
  358. -[0:X ]-+-[1:+ ]-+-[2:a ]
  359.         |        |
  360.         |        `-[10:+]-+-[11:b]
  361.         |                 |
  362.         |                 `-[17:+]-+-[18:c]
  363.         |                          |
  364.         |                          `-[22:+]-+-[23:d]
  365.         |                                   |
  366.         |                                   `-[25:0]
  367.         |
  368.         +-[10:<]
  369.         |
  370.         +-[17:<]
  371.         |
  372.         +-[22:<]
  373.         |
  374.         `-[25:<]
  375.  
  376. -}----------------------------------------------------------------------------
  377.