module Arithmetic_expressions () where
import Prelude hiding (exp, (+), (*), (^))
infixr 6 :+ 
infixr 7 :*
infixr 8 :^
{-
Here is a data type of open arithmetic expressions. 
-}

data E = Zero 
       | One 
       | E :+ E 
       | E :* E 
       | E :^ E
       | Var String
       | Sum [E]
       | Prod [E]
         deriving (Eq, Show)


{-
Here are some examples.
-}
one   = One
two   = One   :+ One
three = One   :+ two
four  = two   :* two
five  = two   :+ three
six   = two   :* three
seven = three :+ four
eight = two   :^ three
nine  = three :^ two
ten   = two   :* five
kilo  = two   :^ ten

vw = Var "w"
vx = Var "x"
vy = Var "y"
vz = Var "z"

{-
Here we define (by structural recursion) 
some operations on expressions that `perform arithmetic'.
-}
e1 + e2 = case e2 of 
	      Zero	-> e1
	      f1 :+ f2  -> (e1 + f1) + f2
              Sum fs    -> Sum (e1:fs)   -- foldr (.) id [ (+ f) | f <- fs ] e1
	      _		-> case e1 of Zero -> e2
				      _    -> e1 :+ e2

e1 * e2 = case e2 of 
	      Zero      -> Zero 
	      One	-> e1
	      f1 :+ f2  -> (e1 * f1) + (e1 * f2)
              Sum fs    -> Sum [ e1 * f | f <- fs ] 
	      f1 :* f2  -> (e1 * f1) * f2
              Prod fs   -> Prod (e1:fs)  -- foldr (.) id [ (* f) | f <- fs ] e1 
	      _		-> case e1 of One  -> e2
				      _    -> e1 :* e2

e1 ^ e2 = case e2 of 
	      Zero	-> One
	      One	-> e1
	      f1 :+ f2  -> (e1 ^ f1) * (e1 ^ f2)
              Sum fs    -> Prod [ e1 ^ f | f <- fs ] 
	      f1 :* f2  -> (e1 ^ f1) ^ f2 
              Prod fs   -> foldr (.) id [ (^ f) | f <- fs ] e1
	      _		-> e1 :^ e2

{- rewrite an arithmetic expression to fully evaluated form -}
eval e  = case e of 
	      e1 :+ e2  -> eval e1 + eval e2
              Sum es    -> foldr (.) id [ (+eval e) | e <- es ] Zero
	      e1 :* e2  -> eval e1 * eval e2
              Prod es   -> foldr (.) id [ (*eval e) | e <- es ] One
	      e1 :^ e2  -> eval e1 ^ eval e2
	      _		-> e



-----------------------------------------------------------------
{-
tod b e 
      = let tod' = tod True
	in
	case e of
	  Zero -> text "0"
	  One  -> text "1"
	  Var str 
	       -> text str
	  e1 :+ e2 
	       -> let (e':es) = fladd e 
		  in par b (sep (tod' e':map (((text "+") <+>) . tod') es))
	  e1 :* e2 
	       -> let (e':es) = flmul e 
		  in par b (sep (tod' e':map (((text "*") <+>) . tod') es))
	  e1 :^ e2 
	       -> let (e':es) = flexp e 
		  in par b (sep (tod' e':map (((text "^") <+>) . tod') es))
	  _    -> error ("unimp: "++show e)

    
par b d = if b then text "(" <> d <> text ")" else d

fladd (e1 :+ e2)  = fladd e1 ++ fladd e2
fladd e		  = [e]
flmul (e1 :* e2)  = flmul e1 ++ flmul e2
flmul e		  = [e]
flexp (e1 :^ e2)  = flexp e1 ++ flexp e2
flexp e		  = [e]

-}