{-----------------------------------------
  Expression interpreter: fancy version
  (variables, polynomials, asbtract parsing)
 -----------------------------------------}

--------------------
-- Expression trees and their fold

data Expr = Lit Int | Var | Opr Op Expr Expr  deriving (Eq, Show)

fold f g x (Lit n)     = f n
fold f g x  Var        = x
fold f g x (Opr o l r) = g o (fold f g x l) (fold f g x r)


--------------------
-- Operators and conversions

data Op = Add | Mul | Sub  deriving (Eq, Show)

isOpSym = (`elem` "+*-")

rop '+' = Add ;  rop '*' = Mul ;  rop '-' = Sub
syn Add = "+" ;  syn Mul = "*" ;  syn Sub = "-"
sem Add = (+) ;  sem Mul = (*) ;  sem Sub = (-)


--------------------
-- Tokens and scanning

data Token = Num Int | Sym Char | IdX  deriving (Read,Show)

scan [] = []
scan (c:cs) | isSpace c =         scan cs
            | isOpSym c = Sym c : scan cs
            | (=='x') c = IdX   : scan cs
            | isDigit c = Num n : scan cs'
            | otherwise = error "bad symbol"
                          where [(n,cs')] = readDec (c:cs)


--------------------
-- Parsing into a tree (with abstract constructors)

parse f g x cs = case foldl shred [] (scan cs) of
                   [t] -> t
                   s   -> error "too few ops"
             
                 where shred      s  (Num n) = f      n      : s
                       shred      s   IdX    = x             : s
                       shred (a:b:s) (Sym c) = g (rop c) b a : s
                       shred      s   _ = error "too few args"


----------------------------------------
-- Various printing, evaluating and parsing combinations

prti  = fold show inf  "x"
prtp  = fold show pof  "x"

eval  = fold id   sem
subst = fold Lit  Opr
defn  = fold Lit  Opr . Lit

trace n = fold ((:[]) . Lit) (comb n) [Lit n, Var]

poly  = fold (:[]) psem [0,1]

parTree = parse Lit   Opr   Var
parVal  = parse id    sem
parPoly = parse (:[]) psem [0,1]
parInf  = parse show  inf  "x"
parPost = parse show  pof  "x"


--------------------
-- Calculation traces

comb n op ls@(l:_) (r:tr) = let (&) = Opr op in
  Lit (eval n (l&r)) : [x&r | x<-ls] ++ [last ls & y | y<-tr]

calc n = putStr . fmtEqns . map prti . reverse . trace n


--------------------
-- Print formatting utilities

inf o l r = par (unwords [l, syn o, r])
pof o l r =      unwords [l, r, syn o]

par = ("("++) . (++")")

fmtEqns = ("      "++) . foldl1 (\x y -> x++"\n  =>  "++y)


--------------------
-- Evaluation and semantic operations on polynomials
-- (represented as reversed lists of coefficients)
-- {theorem:  eval  ==  pval . poly }

pval cs x = foldr (\c r -> c + x * r) 0 cs

ps, pd :: [Int] -> [Int] -> [Int]

ps = lzw (+) 0
pd = lzw (-) 0

pm cs ds = foldr (\c r -> ps (map (c *) ds) (0 : r)) [] cs

-- polynomial semantics for operators

psem Add = ps ;  psem Mul = pm ;  psem Sub = pd

-- Polynomial utility function ("long" zipWith)

lzw f u []     []     = []
lzw f u (x:xs) []     = f x u : lzw f u xs []
lzw f u []     (y:ys) = f u y : lzw f u [] ys
lzw f u (x:xs) (y:ys) = f x y : lzw f u xs ys


--------------------
-- Test data, "generating functions" and notation


[(+:), (*:), (-:)] = map Opr [Add, Mul, Sub]

t0 = (Var *: Lit 2) *: ((Lit 3 +: Var) -: Lit 4)
s0 = "2 3 + 5 x + 4 - *"

t1 = (Lit 2 *: Var) +:  (Var +: Lit 5)
t2 = bump t1 -: t1

t3 = t0 *: t1

bump = fold (Lit . succ)   Opr        Var
mirr = fold  Lit  (\o l r->Opr o r l) Var


------------------------------------------------------------