module Monadic where


--------------------
-- Arithmetic operators

data Opr = Add | Mul  deriving Show

fopr f g Add = f; fopr f g Mul = g

syn = fopr "+" "*"
sem = fopr (+) (*)


--------------------
-- Arithmetic terms with imperative variables

data Expr a b c = Lit a
                | Use c
                | Set c (Expr a b c)
                | Bop b (Expr a b c) (Expr a b c)    deriving Show

infx (Lit k)     = show k
infx (Use x)     = x
infx (Set x e)   = inpar "=" x (infx e)
infx (Bop b l r) = inpar (syn b) (infx l) (infx r)

inpar o l r = concat ["(",l," ",o," ",r,")"]


--------------------
-- Evaluation in direct recursive style

eval (Lit k)     s  =  (k,   s)

eval (Use x)     s  =  (s x, s)

eval (Set x e)   s  =  let (v,t) = eval e s
                       in (v, update s x v)
                     
eval (Bop b l r) s  =  let (v,t) = eval r s
                           (w,u) = eval l t
                       in (sem b w v, u)

try e = fst (eval e (const 0))


--------------------
-- Imperative (state) monad and state functions

newtype Imp s a = Imp (s -> (a,s))

instance Monad (Imp s) where
  return v    = Imp (\s -> (v,s))
  Imp p >>= f = Imp (\s -> let (v,t) = p s
                               Imp q = f v
                           in q t)

update f x v = \y -> if y==x then v else f y

get x   = Imp (\s -> (s x, s))
set x v = Imp (\s -> ((), update s x v))


--------------------
-- Evaluation in monadic style

mval (Lit k)     = do return k

mval (Use x)     = do v <- get x
                      return v

mval (Set x e)   = do v <- mval e
                      set x v
                      return v

mval (Bop b l r) = do v <- mval r
                      w <- mval l
                      return (sem b w v)

try' e = let (Imp s) = mval e in fst (s (const 0))


--------------------
-- Test sample

--  (x * (x = 2)) + ((5 * x) + ((x = 3) * 4))

test = Bop Add (Bop Mul (Use "x") (Set "x" (Lit 2)))
               (Bop Add (Bop Mul (Lit 5) (Use "x"))
                        (Bop Mul (Set "x" (Lit 3)) (Lit 4)))

--  Right to left:

--  (x * (x = 2)) + ((5 * x) + ((x = 3) * 4))       { _ = 0 }
--  (x * (x = 2)) + ((5 * x) + (   3    * 4))       { x = 3 }
--  (x * (x = 2)) + ((5 * x) + (     12    ))       { x = 3 }
--  (x * (x = 2)) + ((5 * 3) + 12           )       { x = 3 }
--  (x * (x = 2)) + (  15    + 12           )       { x = 3 }
--  (x * (x = 2)) + 27                              { x = 3 }
--  (x * 2      ) + 27                              { x = 2 }  <-- NB!
--  (2 * 2      ) + 27                              { x = 2 }
--  (  4     ) + 27                                 { x = 2 }
--  31                                              { x = 2 }


--  Left to right:

--  (x * (x = 2)) + ((5 * x) + ((x = 3) * 4))       { _ = 0 }
--  (0 * (x = 2)) + ((5 * x) + ((x = 3) * 4))       { _ = 0 }
--  (0 * 2)       + ((5 * x) + ((x = 3) * 4))       { x = 2 }  <-- NB!
--  0             + ((5 * x) + ((x = 3) * 4))       { x = 2 }
--  0             + ((5 * 2) + ((x = 3) * 4))       { x = 2 }
--  0             + (10      + ((x = 3) * 4))       { x = 2 }
--  0             + (10      + (3       * 4))       { x = 3 }  <-- NB!
--  0             + (10      + 12)                  { x = 3 }
--  0             + 22                              { x = 3 }
--  22                                              { x = 3 }