module Expr2 where

default (Int)

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

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

data Expr = Lit Int | Bop AOp Expr Expr | Var  deriving (Eq, Show)

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


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

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

isOpChr = (`elem` "+*-")
rop '+' = Add ;  rop '*' = Mul ;  rop '-' = Sub

aop f g h Add = f
aop f g h Mul = g
aop f g h Sub = h

syn = aop "+" "*" "-"
sem = aop (+) (*) (-)


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

data Token = Num Int | Sym AOp | IdX  deriving (Show)

scan [] = []
scan (c:cs) | isSpace c =               scan cs
            | isOpChr c = Sym (rop c) : scan cs
            | (=='x') c = IdX         : scan cs
            | isDigit c = Num (dec n) : scan cs'
            | otherwise = error ("bad symbol ("++c:")")
                          where (n,cs') = span isDigit (c:cs)

dec = foldl (sumProd 10) 0 . map digitToInt
sumProd b x y = b * x + y


--------------------
-- 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 (a:b:s) (Sym o) = g o b a : s
                       shred      s   IdX    = x       : s
                       shred      s   _ = error "too few args"


----------------------------------------
-- Various printing, evaluating and parsing combinations
-- (strictly speaking, some of these should be flipped)

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

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

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

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

parTree = parse Lit   Bop   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 (&) = Bop op in
  Lit (eval n (l&r)) : map (&r) ls ++ map (last ls &) tr


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


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

inf o l r = par $ concat [l,syn o,r]
pof o l r =      unwords [l,r,syn o]

par s = "("++ s ++")"

dispeq = ("   "++) . foldr1 (\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 (flip (sumProd x)) 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 = aop ps pm 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 Bop [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)   Bop        Var
mirr = fold  Lit  (\o l r->Bop o r l) Var


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

sp (*) (+) b x y = x * b + y
phorn  = foldl (sp (Bop Mul) (Bop Add) Var) (Lit 0) . map Lit . reverse
phorn' = foldr1 (flip (sp (Bop Mul) (Bop Add) Var)) . map Lit