module Expr1 where

default (Int)

-------------------------------------------
-- Expression interpreter: simple version
-- (constr parsing, tracing, print options)
-------------------------------------------

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

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

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


--------------------
-- 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  deriving (Show)

scan [] = []
scan (c:cs) | isSpace c =               scan cs
            | isOpChr c = Sym (rop c) : 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 a list of tokens into a tree (using a stack)

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


--------------------
-- Evaluation and pretty-printing

eval  = fold id sem

trace = fold sing comb  where sing k = [Lit k]

prti  = fold show inf
prtp  = fold show pof

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

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

-- ppeq prints with embedded results

ppeq = fst . fold (\k -> (show k, k)) popr
popr o (s,k) (t,j) = (concat ["(",s,syn o,t,"=",show n,")"], n)
                     where n = sem o k j


--------------------
-- Tracing a calculation

comb op ls@(l:_) (r:tr) = let (&) = Bop op in
  Lit (eval (l&r)) : map (&r) ls ++ map (last ls &) tr

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

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


--------------------
-- for efficiency, semantic domain could be ([S->S],V)

calc' = putStr . dispeq . map ($"") . fst . trace'

trace' = fold sing comb'  where sing k = ([(show k++)], k)

comb' op (l:ls,v) (r:rs,w) = let (&) = inf' op; u = sem op v w in
  (inf' op l r : map (l&) rs ++ map (&(show w++)) ls ++ [(show u++)],u)

inf' o l r = ('(':) . l . (syn o++) . r . (')':)


{-
--------------------
-- for efficiency, semantic domain could be ([E],V)
-- (but we still have to repeatedly traverse the lists)

calc' = putStr . dispeq . map prti . fst . trace'

trace' = fold sing comb'  where sing k = ([Lit k], k)

comb' op (l:ls,v) (r:rs,w) = let (&) = Bop op; u = sem op v w in
  (l&r : map (l&) rs ++ map (&Lit w) ls ++ [Lit u], u)
-}

{-
--------------------
-- for efficiency, semantic domain could be (E,[E]->[E],V)
-- (but then we can't map on *only* the first list ...)

mid (_,f,_) = f []

calc' = putStr . dispeq . map prti . mid . trace'

trace' = fold sing comb'  where sing k = (Lit k, (Lit k:), k)

comb' op (s,f,v) (t,g,w) = let (&) = Bop op; u = sem op v w in
  (s & t, map (& Lit w) . f . map (Lit v &) . g, u)
-}


--------------------
-- Some test data


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

bump = fold (Lit . succ) Bop

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

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

t3 = (t2 +: bump t2) *: (bump t2 -: t2)


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