-- 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:<]
-}----------------------------------------------------------------------------
|
