--
```

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
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
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
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
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
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
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
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
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
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
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
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
| Sub x x
| Times x x
| Int Int

instance (Eval e v m,Num v)
=> Eval (Arith e) v m where
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))

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)

------------------------------------------
return x = Id x
(>>=) (Id x) f = f x

return x = Ok x
(>>=) (Ok x) f = f x
(>>=) Fail f = Fail

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)
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))

------------------------------
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)

-------------------------
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 ])

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