content: -- This is a program to illustrate a simple form of common subexpression
  -- elimination ... essentially turning trees into DAGs.  Uses two state
  -- monads (more precisely, same monad but different state types).
  -- This program doesn't use constructor classes, although it could
  -- obviously be modified to fit into that framework.
  --
  -- This programs should be loaded after `stateMonad':  For example:
  --  ? :l stateMonad.gs csexpr.gs
  --  ? test
  --
  -- The output for this `test' is included at the end of the file.
  --
  -- Mark P. Jones, 1992
  --
  
  module Main (main) where
  
  import StateMonad
  
  -- partain: I think this has to be here
  infix +=>      -- overide function at single point
  
  -- Data type definitions: ----------------------------------------------------
  
  data GenTree a  = Node a [GenTree a]
  type LabGraph a = [ (Label, a, [Label]) ]
  type Label      = Int
  
  -- Add distinct (integer) labels to each node of a tree: ---------------------
  
  labelTree   :: GenTree a -> GenTree (Label,a)
  labelTree t  = label t `startingWith` 0
                 where label (Node x xs) = incr           `bind` \n  ->
                                           mmapl label xs `bind` \ts ->
                                           retURN (Node (n,x) ts)
  
  -- Convert tree after labelling each node to a labelled graph: ---------------
  
  ltGraph                :: GenTree (Label,a) -> LabGraph a
  ltGraph (Node (n,x) xs) = (n, x, map labelOf xs) : concat (map ltGraph xs)
                            where labelOf (Node (n,x) xs) = n
  
  -- Build tree from labelled graph: -------------------------------------------
  
  unGraph              :: LabGraph a -> GenTree a
  unGraph ((n,x,cs):ts) = Node x (map (unGraph . find) cs)
                          where find c = dropWhile (\(d,_,_) -> c/=d) ts
  
  
  -- Build tree but avoid duplicating shared parts: ----------------------------
  
  unGraph'     :: LabGraph String -> GenTree (Int,String)
  unGraph' lg   = ung lg `startingWith` []
   where ung ((n,x,cs):ts) = mif (visited n)
                                   (retURN (Node (n,"<>") []))
                                   (mmapl (ung . find) cs `bind` \ts ->
                                    retURN (Node (n,x) ts))
                             where find c = dropWhile (\(d,_,_) -> c/=d) ts
  
  visited      :: Label -> SM [Label] Bool
  visited n     = fetch                               `bind` \us ->
                  if n `elem` us then retURN True
                                 else set (n:us)      `bind` \_ -> 
                                      retURN False
  
  -- Find (and eliminate) repeated subtrees in a labelled graph: ---------------
  -- Described as a transformation on labelled graphs:  During the calculation
  -- we use a pair (r,lg) :: (Label->Label, LabGraph a) where lg contains the
  -- simplified portion of the graph calculated so far and r is a renaming (or
  -- replacement?) which maps node labels in the original graph to the approp.
  -- labels in the new graph.
  
  findCommon :: Eq a => LabGraph a -> LabGraph a
  findCommon  = snd . foldr sim (id,[])
   where
     sim ::
       Eq a => (Label,a,[Label]) -> (Label -> Label, LabGraph a) ->
       (Label -> Label, LabGraph a)
     sim (n,s,cs) (r,lg) =
       if null ms then
         (r, [(n,s,rcs)] ++ lg)
       else
         ((n +=> head ms) r, lg)
           where
  	   ms  = [m | (m,s',cs')<-lg, s==s', cs'==rcs]
             rcs = map r cs
  
  (+=>) :: Eq a => a -> b -> (a -> b) -> (a -> b)
  (+=>) x fx f y  = if x==y then fx else f y
  
  -- Common subexpression elimination: -----------------------------------------
  
  cse :: Eq a => GenTree a -> LabGraph a
  cse  = findCommon . ltGraph . labelTree
  
  -- Pretty printers: ----------------------------------------------------------
  
  instance Show a => Show (GenTree a) where
      showsPrec d (Node x ts)
          | null ts   = shows x
          | otherwise = showChar '(' . shows x
                                     . showChar ' '
                                     . (foldr1 (\x y -> x . showChar ' ' . y)
                                               (map shows ts))
                                     . showChar ')'
  
  copy            :: Int -> a -> [a]
  copy  n x        = take n (repeat x)
  space n          = copy n ' '
  
  drawTree        :: GenTree String -> String
  drawTree         = unlines . draw
  draw (Node x ts) = grp (s1 ++ pad width x ++ "]") (space (width+3)) (stLoop ts)
   where stLoop []     = [""]
         stLoop [t]    = grp s2 "  " (draw t)
         stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
  
         rsLoop [t]    = grp s5 "  " (draw t)
         rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
  
         grp fst rst   = zipWith (++) (fst:repeat rst)
  
         -- Define the strings used to print tree diagrams:
         [s1,s2,s3,s4,s5,s6] | pcGraphics = ["\196[", "\196\196", "\196\194",
                                             " \179", " \192",    " \195"]
                             | otherwise  = ["-[",    "--",       "-+",
                                             " |",    " `",       " +"]
  
         pad n x    = take n (x ++ repeat ' ')
         width      = 4
         pcGraphics = False
  
  showGraph   :: Show a => LabGraph a -> String
  showGraph [] = "[]\n"
  showGraph xs = "[" ++ loop (map show xs)
                 where loop [x]    = x ++ "]\n"
                       loop (x:xs) = x ++ ",\n " ++ loop xs
  
  -- Examples: -----------------------------------------------------------------
  
  plus x y = Node "+" [x,y]
  mult x y = Node "*" [x,y]
  prod xs  = Node "X" xs
  zerO     = Node "0" []
  a        = Node "a" []
  b        = Node "b" []
  c        = Node "c" []
  d        = Node "d" []
  
  examples = [example0, example1, example2, example3, example4, example5]
  example0 = a
  example1 = plus a a
  example2 = plus (mult a b) (mult a b)
  example3 = plus (mult (plus a b) c) (plus a b)
  example4 = prod (scanl plus zerO [a,b,c,d])
  example5 = prod (scanr plus zerO [a,b,c,d])
  
  main  = putStr -- writeFile "csoutput"
           (unlines (map (\t -> let c = cse t
                                in  copy 78 '-'            ++
                                    "\nExpression:\n"      ++ show t      ++
                                    "\n\nTree:\n"          ++ drawTree t  ++
                                    "\nLabelled graph:\n"  ++ showGraph c ++
                                    "\nSimplified tree:\n" ++ showCse c)
                         examples))
          where
           showCse                  = drawTree
                                      . mapGenTree (\(n,s) -> show n++":"++s)
                                      . unGraph'
           mapGenTree f (Node x ts) = Node (f x) (map (mapGenTree f) ts)
  
  {-----------------------------------------------------------------------------
  Expression:
  a
  
  Tree:
  -[a   ]
  
  Labelled graph:
  [(0,"a",[])]
  
  Simplified tree:
  -[0:a ]
  
  ------------------------------------------------------------------------------
  Expression:
  (+ a a)
  
  Tree:
  -[+   ]-+-[a   ]
          |
          `-[a   ]
  
  Labelled graph:
  [(0,"+",[2, 2]),
   (2,"a",[])]
  
  Simplified tree:
  -[0:+ ]-+-[2:a ]
          |
          `-[2:<>]
  
  ------------------------------------------------------------------------------
  Expression:
  (+ (* a b) (* a b))
  
  Tree:
  -[+   ]-+-[*   ]-+-[a   ]
          |        |
          |        `-[b   ]
          |
          `-[*   ]-+-[a   ]
                   |
                   `-[b   ]
  
  Labelled graph:
  [(0,"+",[4, 4]),
   (4,"*",[5, 6]),
   (5,"a",[]),
   (6,"b",[])]
  
  Simplified tree:
  -[0:+ ]-+-[4:* ]-+-[5:a ]
          |        |
          |        `-[6:b ]
          |
          `-[4:<>]
  
  ------------------------------------------------------------------------------
  Expression:
  (+ (* (+ a b) c) (+ a b))
  
  Tree:
  -[+   ]-+-[*   ]-+-[+   ]-+-[a   ]
          |        |        |
          |        |        `-[b   ]
          |        |
          |        `-[c   ]
          |
          `-[+   ]-+-[a   ]
                   |
                   `-[b   ]
  
  Labelled graph:
  [(0,"+",[1, 6]),
   (1,"*",[6, 5]),
   (5,"c",[]),
   (6,"+",[7, 8]),
   (7,"a",[]),
   (8,"b",[])]
  
  Simplified tree:
  -[0:+ ]-+-[1:* ]-+-[6:+ ]-+-[7:a ]
          |        |        |
          |        |        `-[8:b ]
          |        |
          |        `-[5:c ]
          |
          `-[6:<>]
  
  ------------------------------------------------------------------------------
  Expression:
  (X 0 (+ 0 a) (+ (+ 0 a) b) (+ (+ (+ 0 a) b) c) (+ (+ (+ (+ 0 a) b) c) d))
  
  Tree:
  -[X   ]-+-[0   ]
          |
          +-[+   ]-+-[0   ]
          |        |
          |        `-[a   ]
          |
          +-[+   ]-+-[+   ]-+-[0   ]
          |        |        |
          |        |        `-[a   ]
          |        |
          |        `-[b   ]
          |
          +-[+   ]-+-[+   ]-+-[+   ]-+-[0   ]
          |        |        |        |
          |        |        |        `-[a   ]
          |        |        |
          |        |        `-[b   ]
          |        |
          |        `-[c   ]
          |
          `-[+   ]-+-[+   ]-+-[+   ]-+-[+   ]-+-[0   ]
                   |        |        |        |
                   |        |        |        `-[a   ]
                   |        |        |
                   |        |        `-[b   ]
                   |        |
                   |        `-[c   ]
                   |
                   `-[d   ]
  
  Labelled graph:
  [(0,"X",[21, 20, 19, 18, 17]),
   (17,"+",[18, 25]),
   (18,"+",[19, 24]),
   (19,"+",[20, 23]),
   (20,"+",[21, 22]),
   (21,"0",[]),
   (22,"a",[]),
   (23,"b",[]),
   (24,"c",[]),
   (25,"d",[])]
  
  Simplified tree:
  -[0:X ]-+-[21:0]
          |
          +-[20:+]-+-[21:<]
          |        |
          |        `-[22:a]
          |
          +-[19:+]-+-[20:<]
          |        |
          |        `-[23:b]
          |
          +-[18:+]-+-[19:<]
          |        |
          |        `-[24:c]
          |
          `-[17:+]-+-[18:<]
                   |
                   `-[25:d]
  
  
  ------------------------------------------------------------------------------
  Expression:
  (X (+ a (+ b (+ c (+ d 0)))) (+ b (+ c (+ d 0))) (+ c (+ d 0)) (+ d 0) 0)
  
  Tree:
  -[X   ]-+-[+   ]-+-[a   ]
          |        |
          |        `-[+   ]-+-[b   ]
          |                 |
          |                 `-[+   ]-+-[c   ]
          |                          |
          |                          `-[+   ]-+-[d   ]
          |                                   |
          |                                   `-[0   ]
          |
          +-[+   ]-+-[b   ]
          |        |
          |        `-[+   ]-+-[c   ]
          |                 |
          |                 `-[+   ]-+-[d   ]
          |                          |
          |                          `-[0   ]
          |
          +-[+   ]-+-[c   ]
          |        |
          |        `-[+   ]-+-[d   ]
          |                 |
          |                 `-[0   ]
          |
          +-[+   ]-+-[d   ]
          |        |
          |        `-[0   ]
          |
          `-[0   ]
  
  Labelled graph:
  [(0,"X",[1, 10, 17, 22, 25]),
   (1,"+",[2, 10]),
   (2,"a",[]),
   (10,"+",[11, 17]),
   (11,"b",[]),
   (17,"+",[18, 22]),
   (18,"c",[]),
   (22,"+",[23, 25]),
   (23,"d",[]),
   (25,"0",[])]
  
  Simplified tree:
  -[0:X ]-+-[1:+ ]-+-[2:a ]
          |        |
          |        `-[10:+]-+-[11:b]
          |                 |
          |                 `-[17:+]-+-[18:c]
          |                          |
          |                          `-[22:+]-+-[23:d]
          |                                   |
          |                                   `-[25:0]
          |
          +-[10:<]
          |
          +-[17:<]
          |
          +-[22:<]
          |
          `-[25:<]
  
  -}----------------------------------------------------------------------------
  