-- <PRE>


data Id x = Id x 

data T1 = Add1 T1 T1
        | Sub1 T1 T1
        | Mult1 T1 T1
        | Int1 Int

type Value = Int

eval1 :: T1 -> Id Value
eval1 (Add1 x y) = 
      do {x' <- eval1 x
         ; y' <- eval1 y
         ; return (x' + y')}
eval1 (Sub1 x y) = 
      do {x' <- eval1 x
         ; y' <- eval1 y
         ; return (x' - y')}
eval1 (Mult1 x y) = 
      do {x' <- eval1 x
         ; y' <- eval1 y
         ; return (x' * y')}
eval1 (Int1 n) = return n      

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

data Exception x = Ok x | Fail

data T2 = Add2 T2 T2
        | Sub2 T2 T2
        | Mult2 T2 T2
        | Int2 Int
        | Div2 T2 T2

eval2a :: T2 -> Exception Value
eval2a (Add2 x y) =
  case (eval2a x,eval2a y)of
    (Ok x', Ok y') -> Ok(x' + y')
    (_,_) -> Fail
eval2a (Sub2 x y) =
  case (eval2a x,eval2a y)of
    (Ok x', Ok y') -> Ok(x' - y')
    (_,_) -> Fail
eval2a (Mult2 x y) =
  case (eval2a x,eval2a y)of
    (Ok x', Ok y') -> Ok(x' * y')
    (_,_) -> Fail
eval2a (Int2 x) = Ok x 
eval2a (Div2 x y) =
  case (eval2a x,eval2a y)of
    (Ok x', Ok 0) -> Fail
    (Ok x', Ok y') -> Ok(div x' y')
    (_,_) -> Fail
    
eval2 :: T2 -> Exception Value
eval2 (Add2 x y) = 
 do { x' <- eval2 x
    ; y' <- eval2 y
    ; return (x' + y')}
eval2 (Sub2 x y) = 
 do { x' <- eval2 x
    ; y' <- eval2 y
    ; return (x' - y')}
eval2 (Mult2 x y) = 
 do { x' <- eval2 x
    ; y' <- eval2 y
    ; return (x' * y')}
eval2 (Int2 n) = return n 
eval2 (Div2 x y) = 
 do { x' <- eval2 x
    ; y' <- eval2 y
    ; if y'==0 
         then Fail 
         else return (div x' y')}

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

data Env e x = Env (e -> x)

data T3 = Add3 T3 T3
        | Sub3 T3 T3
        | Mult3 T3 T3
        | Int3 Int
        | Let3 String T3 T3
        | Var3 String

eval3a :: T3 -> Env Map Value
eval3a (Add3 x y) =
 Env(\e -> 
     let Env f = eval3a x
         Env g = eval3a y
     in (f e) + (g e))
eval3a (Sub3 x y) =
 Env(\e -> 
     let Env f = eval3a x
         Env g = eval3a y
     in (f e) - (g e))
eval3a (Mult3 x y) =
 Env(\e -> 
     let Env f = eval3a x
         Env g = eval3a y
     in (f e) * (g e))
eval3a (Int3 n) =
 Env(\e -> n)
eval3a (Let3 s e1 e2) =
 Env(\e ->
     let Env f = eval3a e1
         env2 = (s,f e):e
         Env g = eval3a e2
     in g env2)
eval3a (Var3 s) = getEnv s
     
     
eval3 :: T3 -> Env Map Value
eval3 (Add3 x y) = 
 do { x' <- eval3 x
    ; y' <- eval3 y
    ; return (x' + y')}
eval3 (Sub3 x y) = 
 do {x' <- eval3 x
    ; y' <- eval3 y
    ; return (x' - y')}
eval3 (Mult3 x y) = 
 do { x' <- eval3 x
    ; y' <- eval3 y
    ; return (x' * y')}
eval3 (Int3 n) = return n
eval3 (Let3 s e1 e2) = 
 do { v <- eval3 e1
     ; runInNewEnv s v (eval3 e2) }
eval3 (Var3 s) = getEnv s

--------------------------------------
data Mult x = Mult [x]

data T4 = Add4 T4 T4
        | Sub4 T4 T4
        | Mult4 T4 T4
        | Int4 [ Int ]

eval4a :: T4 -> Mult Value
eval4a (Add4 x y) = 
 let Mult xs = eval4a x
     Mult ys = eval4a y
 in Mult[ x+y | x <- xs, y <- ys ]
eval4a (Sub4 x y) = 
 let Mult xs = eval4a x
     Mult ys = eval4a y
 in Mult[ x-y | x <- xs, y <- ys ]
eval4a (Mult4 x y) = 
 let Mult xs = eval4a x
     Mult ys = eval4a y
 in Mult[ x*y | x <- xs, y <- ys ]
eval4a (Int4 ns) = Mult ns
 
eval4 :: T4 -> Mult Value
eval4 (Add4 x y) = 
 do { x' <- eval4 x
    ; y' <- eval4 y
    ; return (x' + y')}
eval4 (Sub4 x y) = 
 do { x' <- eval4 x
    ; y' <- eval4 y
    ; return (x' - y')}
eval4 (Mult4 x y) = 
 do { x' <- eval4 x
    ; y' <- eval4 y
    ; return (x' * y')}
eval4 (Int4 ns) = Mult ns 

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

data Store s x = St(s -> (x,s)) 

data T5 = Add5 T5 T5
        | Sub5 T5 T5
        | Mult5 T5 T5
        | Int5 Int
        | Var5 String
        | Assign5 String  T5
        
eval5a :: T5 -> Store Map Value
eval5a (Add5 x y) =
  St(\s-> let St f = eval5a x
              St g = eval5a y
              (x',s1) = f s
              (y',s2) = g s1
          in(x'+y',s2))
eval5a (Sub5 x y) =
  St(\s-> let St f = eval5a x
              St g = eval5a y
              (x',s1) = f s
              (y',s2) = g s1
          in(x'-y',s2))
eval5a (Mult5 x y) =
  St(\s-> let St f = eval5a x
              St g = eval5a y
              (x',s1) = f s
              (y',s2) = g s1
          in(x'*y',s2))
eval5a (Int5 n) = St(\s ->(n,s))
eval5a (Var5 s) = getStore s
eval5a (Assign5 nm x) =
 St(\s -> let St f = eval5a x
              (x',s1) = f s
              build [] = [(nm,x')]
              build ((s,v):zs) = 
               if s==nm 
                  then (s,x'):zs 
                  else (s,v):(build zs)
          in (0,build s1)) 
          
eval5 :: T5 -> Store Map Value
eval5 (Add5 x y) = 
      do {x' <- eval5 x; y' <- eval5 y; return (x' + y')}
eval5 (Sub5 x y) = 
      do {x' <- eval5 x; y' <- eval5 y; return (x' - y')}
eval5 (Mult5 x y) = 
      do {x' <- eval5 x; y' <- eval5 y; return (x' * y')}
eval5 (Int5 n) = return n  
eval5 (Var5 s) = getStore s
eval5 (Assign5 s x) = 
      do { x' <- eval5 x; putStore s x' ; return x' }

--------------------------------------
data Output x = OP(x,String)

type Message = String
data T6 = Add6 T6 T6
        | Sub6 T6 T6
        | Mult6 T6 T6
        | Int6 Int
        | Print6 Message T6

eval6a :: T6 -> Output Value
eval6a (Add6 x y) =
 let OP(x',s1) = eval6a x
     OP(y',s2) = eval6a y
 in OP(x'+y',s1++s2)
eval6a (Sub6 x y) =
 let OP(x',s1) = eval6a x
     OP(y',s2) = eval6a y
 in OP(x'-y',s1++s2)
eval6a (Mult6 x y) =
 let OP(x',s1) = eval6a x
     OP(y',s2) = eval6a y
 in OP(x'*y',s1++s2)
eval6a (Int6 n) = OP(n,"")
eval6a (Print6 mess x) =
 let OP(x',s1) = eval6a x
 in OP(x',s1++mess++(show x'))
 
eval6 :: T6 -> Output Value
eval6 (Add6 x y) = 
 do { x' <- eval6 x
    ; y' <- eval6 y
    ; return (x' + y')}
eval6 (Sub6 x y) = 
 do { x' <- eval6 x
    ; y' <- eval6 y
    ; return (x' - y')}
eval6 (Mult6 x y) = 
 do { x' <- eval6 x
    ; y' <- eval6 y
    ; return (x' * y')}
eval6 (Int6 n) = return n   
eval6 (Print6 mess x) =
 do { x' <- eval6 x
    ; printOutput (mess++(show x'))
    ; return x'}

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

class Monad m => Eval e v m where
  eval :: e -> m v

data Arith x 
  = Add x x
  | Sub x x 
  | Times x x
  | Int Int

instance (Eval e v m,Num v) 
           => Eval (Arith e) v m where
  eval (Add x y) =  
     do { x' <- eval x
        ; y' <- eval y
        ; return (x'+y') }
  eval (Sub x y) = 
     do { x' <- eval x
        ; y' <- eval y
        ; return (x'-y') }
  eval (Times x y) =
     do { x' <- eval x
        ; y' <- eval y
        ; return (x'* y') }
  eval (Int n) = return (fromInt n)

instance Show e => Show (Arith e) where
  show (Add x y) = (show x) ++" + "++(show y)
  show (Sub x y) = (show x) ++" - "++(show y)
  show (Times x y) = (show x) ++" * "++(show y)
  show (Int n) = (show n)
  

-------------------------------------------  
data Divisible x 
  = Div x x

class Monad m => Failure m where
  fails :: m a
  
instance (Failure m, Integral v, Eval e v m) => 
         Eval (Divisible e) v m where
  eval (Div x y) =
    do { x' <- eval x
       ; y' <- eval y
       ; if (toInt x') == 0
            then fails
            else return(x' `div` y')
       }
       
instance Show e => Show (Divisible e) where
  show (Div x y) = (show x) ++" / "++(show y)
  
------------------------------------------------

data LocalLet x
  = Let String x x
  | Var String

class Monad m => HasEnv m v where
  inNewEnv :: String -> v -> m v -> m v
  getfromEnv :: String -> m v

instance (HasEnv m v,Eval e v m) => Eval (LocalLet e) v m where
  eval (Let s x y) = 
    do { x' <- eval x
       ; inNewEnv s x' (eval y)
       }
  eval (Var s) = getfromEnv s
  
instance Show e => Show (LocalLet e) where
  show (Let s x y) = "let "++(showString s "")++" = "++(show x)++" in "++(show y)
  show (Var s) = showString s ""
  
--------------------------------------
  
data Assignment x
  = Assign String x
  | Loc String
  
class Monad m => HasStore m v where   
  getfromStore :: String -> m v
  putinStore :: String -> v -> m v
  
instance (HasStore m v,Eval e v m) => Eval (Assignment e) v m where
  eval (Assign s x) =
    do { x' <- eval x
       ; putinStore s x' }
  eval (Loc s) = getfromStore s

instance Show e => Show (Assignment e) where
  show (Assign s x) = (showString s "")++" := "++(show x)
  show (Loc s) = showString s ""
  
----------------------------------  
data Print x 
  = Write String x
  
class (Monad m,Show v) => Prints m v where
  write :: String -> v -> m v

instance (Prints m v,Eval e v m) => Eval (Print e) v m where
  eval (Write message x)  =
    do { x' <- eval x
       ; write message x' }
       
instance Show e => Show (Print e) where
  show (Write s x) = "Print "++(showString s "")++" = "++(show x) 

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

data Term 
  = Arith (Arith Term)
  | Divisible (Divisible Term)
  | LocalLet (LocalLet Term)
  | Assignment (Assignment Term)
  | Print (Print Term)
  
instance (Monad m, Failure m,Integral v,
          HasEnv m v, HasStore m v, Prints m v) =>
         Eval Term v m where  
  eval (Arith x) = eval x
  eval (Divisible x) = eval x
  eval (LocalLet x) = eval x
  eval (Assignment x) = eval x
  eval (Print x) = eval x


instance Show Term where
  show (Arith x) = show x
  show (Divisible x) = show x
  show (LocalLet x) = show x
  show (Assignment x) = show x
  show (Print x) = show x


type Maps x = [(String,x)]
data M v x = M(Maps v -> Maps v -> (Maybe x,String,Maps v))


instance Monad (M v) where
 return x = M(\ st env -> (Just x,[],st))
 (>>=) (M f) g = M h
   where h st env = compare env (f st env)
         compare env (Nothing,op1,st1)  = (Nothing,op1,st1)
         compare env (Just x, op1,st1)  = next env op1 st1 (g x)
         next env op1 st1 (M f2)        = compare2 op1 (f2 st1 env)
         compare2 op1 (Nothing,op2,st2) = (Nothing,op1++op2,st2)
         compare2 op1 (Just y, op2,st2) = (Just y, op1++op2,st2)


instance Failure (M v) where
  fails = M(\ st env -> (Nothing,[],st))

get name ((a,b):m) = if a==name then b else get name m

instance HasEnv (M v) v where
  inNewEnv name v (M f) = M(\ st env -> f st ((name,v):env))
  getfromEnv name = M h
     where h st env = (Just(get name env),[],st)
           
instance HasStore (M v) v where
  getfromStore name = M h
     where h st env = (Just(get name st),[],st)
  putinStore name v = M h
     where h st env = (Just v,[],(name,v):st)
     
instance Show v => Prints (M v) v where
  write message v = M h
     where h st env = (Just v,message++(show v),st)


------------------------------------------
instance Monad Id where
  return x = Id x
  (>>=) (Id x) f = f x
 
instance Monad Exception where
  return x = Ok x
  (>>=) (Ok x) f = f x
  (>>=) Fail f = Fail
 
instance Monad (Env e) where
  return x = Env(\ e -> x)
  (>>=) (Env f) g = Env(\ e -> let Env h = g (f e)
                               in h e)


qq x yf =
  let Env f = x
      h e = let x = f e
                Env g = yf x
            in g e
  in Env h 

type Map = [(String,Value)]   

getEnv :: String -> (Env Map Value)
getEnv nm = Env(\ s -> find s)
  where find [] = error ("Name: "++nm++" not found")
        find ((s,n):m) = if s==nm then n else find m

runInNewEnv :: String -> Int -> (Env Map Value) -> (Env Map Value)
runInNewEnv s n (Env g) = Env(\ m -> g ((s,n):m))

------------------------------
instance Monad (Store s) where
  return x = St(\ s -> (x,s))
  (>>=) (St f) g = St(\ s1 -> let (x,s2) = f s1
                                  St g' = g x
                              in g' s2)
                                    
                                    
tt x yf =
 let St f = x
     h s1 = let (x,s2) = f s1
                St g = yf x
                (y,s3) = g s2
            in (y,s3)
 in St h
                                    
getStore :: String -> (Store Map Value)
getStore nm = St(\ s -> find s s)
  where find w [] = (0,w)
        find w ((s,n):m) = if s==nm then (n,w) else find w m

putStore :: String -> Value -> (Store Map ())
putStore nm n = (St(\ s -> ((),build s)))
  where build [] = [(nm,n)]
        build ((s,v):zs) = 
           if s==nm then (s,n):zs else (s,v):(build zs)

-------------------------    
instance Monad Mult where
  return x = Mult[x]
  (>>=) (Mult zs) f = Mult(flat(map f zs))
     where flat [] = []
           flat ((Mult xs):zs) = xs ++ (flat zs)
 

zz x yf =
  let Mult xs = x
      ys = map yf xs
  in Mult (concat[ z | Mult z <- ys ])

---------------------------    
instance Monad Output where
  return x = OP(x,"")
  (>>=) (OP(x,s1)) f = let OP(y,s2) = f x in OP(y,s1 ++ s2)

printOutput:: String -> Output ()
printOutput s = OP((),s)

--</PRE>