module PolyL15 where

------------------------------ Expressions with a single, distinguished variable

data Expr a b = Lit a | Bop b (Expr a b) (Expr a b) | Var  -- deriving (Eq,Show)


----- the fold will now take an extra argument and clause as well

foldx f g h (Lit a)     = f a
foldx f g h (Bop b l r) = g b (foldx f g h l) (foldx f g h r)
foldx f g h  Var        = h


------------------------------ Operator syntax and semantics (same as before)

data Opr = Add | Mul  deriving (Eq,Show)

foldo f g Add = f
foldo f g Mul = g

evalo = foldo (+) (*)
prnto = foldo "+" "*"


----- printing stays almost the same (just add "x")
----- (let's agree to use integers in the leaves, rather than numerals)

prntx e = foldx show (infx . prnto) "x" e

instance (Show a) => Show (Expr a Opr) where
  show = prntx


------------------------------ expression evaluation

----- evaluation should now produce a *function*

evalx0 (Lit k)     = \n -> k
evalx0 (Bop o l r) = \n -> evalo o (evalx0 l n) (evalx0 r n)
evalx0  Var        = \n -> n


----- this isn't in the form of a fold, but we can re-cast it that way

lift f g h x = f (g x) (h x)

evalx1 (Lit k)     = const k
evalx1 (Bop o l r) = lift (evalo o) (evalx1 l) (evalx1 r)
evalx1  Var        = id

evalx2 = foldx const (lift . evalo) id


----- another (equivalent!) way to do it is to lift the semantics of operators

evalol = foldo (lift (+)) (lift (*))
evalx3 = foldx const evalol id

----- { prove that:   lift . foldo (+) (*)  ==  foldo (lift (+)) (lift (*))   }


----- finally, we have this "cute trick": just flip expr and "var" arguments

evalx4 e n = foldx id evalo n e
evalx5 = flip (foldx id evalo)


------------------------------ substitution and application

comp = flip (foldx Lit Bop)
appl = flip (foldx Lit Bop . Lit)


------------------------------ polynomials as (reversed) lists of coefficients

----- poly add and poly multiply

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

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


----- polynomial semantics

evalpo = foldo pa pm
evalpx = foldx (:[]) evalpo [0,1]


------------------------------ printing for polynomials

infixr 0 ?                          -- read "s ? b" in English as "s when b"

(?) s b = if b then s else ""

showp k (c:cs) = (showp (k+1) cs ++ " + " ? cs/=[]) 
                 ++ (show c ? k==0 || c/=1 )
                 ++ ("x"    ? k>0)
                 ++ ("^" ++ show k ? k>1)

prntp = showp 0


------------------------------ helper functions for pretty-printing

infx o l r = par (concat [l,o,r])
prfx o l r = unwords [o,l,r]
pofx o l r = unwords [l,r,o]

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


------------------------------ polynomial for the "comp sampx sampx" example

pp x = x^4 + 10 * x^3 + 42 * x^2 + 85 * x + 72




------------------------------ some other handy testing stuff

sampx = Bop Mul (Bop Add Var (Lit 2)) (Bop Add Var (Lit 3))     -- sampx = (x+2) * (x+3)

p x = x^2 + 5*x + 6

test10 f g = and [f x == g x | x <- [0..10]]

test m = test10 (m sampx) p

testall = all test [evalx0, evalx1, evalx2, evalx3, evalx4, evalx5]

testc  = test10 (evalx5 (comp sampx sampx)) (p . p)

testc' = test10 (evalx5 (comp sampx sampx)) (evalx5 sampx . evalx5 sampx)


------------------------------ multiple samples in a list

samps = [ Lit 1, Lit 2, Var, Bop Add Var (Lit 3), Bop Mul (Lit 4) Var, 
          Bop Add Var (Bop Mul (Lit 5) Var), sampx ]

try f = mapM_ (putStrLn . fmt) $ f samps
        where fmt e = "\n" ++ prntx e ++ "\n  =  " ++ prntp (evalpx e)

    --  try id
    --  try (map (`appl` 2))
    --  try (map (comp sampx))
    --  try (scanr1 comp)
    --  try (scanl1 (Bop Add))
    --  try (scanl1 (Bop Mul))