--
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} data Id x = Id x deriving Show data T1 = Add1 T1 T1 | Sub1 T1 T1 | Mult1 T1 T1 | Int1 Int deriving Show 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 deriving Show t2 = Add2 (Mult2 (Int2 2) (Int2 5)) (Int2 3) t2a = Add2 (Div2 (Int2 2) (Int2 0)) (Int2 3) data T2 = Add2 T2 T2 | Sub2 T2 T2 | Mult2 T2 T2 | Int2 Int | Div2 T2 T2 deriving Show 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 deriving Show 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] deriving Show t4 = Add4 (Mult4 (Int4 2) (Int4 5)) (Int4 3) t4a = Add4 (Mult4 (Choose4 (Int4 2) (Int4 6)) (Choose4 (Int4 5) (Int4 3))) (Choose4 (Int4 3) (Int4 0)) t4b = Sqrt4 (Int4 5) t4c = Add4 (Int4 1) (Sqrt4 (Int4 (-3))) data T4 = Add4 T4 T4 | Sub4 T4 T4 | Mult4 T4 T4 | Int4 Int | Choose4 T4 T4 | Sqrt4 T4 deriving Show 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 n) = Mult [n] eval4a (Choose4 x y) = let Mult xs = eval4a x Mult ys = eval4a y in Mult (xs++ys) eval4a (Sqrt4 x) = let Mult xs = eval4a x in Mult(roots xs) roots [] = [] roots (x:xs) | x<0 = roots xs roots (x:xs) = y : z : roots xs where y = root x z = negate y root:: Int -> Int root n = floor(sqrt (fromIntegral n)) 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 n) = return n eval4 (Choose4 x y) = merge (eval4a x) (eval4a y) eval4 (Sqrt4 x) = do { n <- eval4 x ; if n < 0 then none else merge (return (root n)) (return(negate(root n))) } merge :: Mult a -> Mult a -> Mult a merge (Mult xs) (Mult ys) = Mult(xs++ys) none = Mult [] -------------------------------------- data Output x = OP(x,String) deriving Show t6 = Add6 (Mult6 (Int6 2) (Print6 "Hi" (Int6 5))) (Int6 3) t6a = Print6 "Low" $ Add6 (Mult6 (Int6 2) (Print6 "Hi" (Int6 5))) (Int6 3) type Message = String data T6 = Add6 T6 T6 | Sub6 T6 T6 | Mult6 T6 T6 | Int6 Int | Print6 Message T6 deriving Show 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 (fromIntegral 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 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) 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) 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 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) ------------------------------------------------- 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 deriving Show 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' } find :: Eq a => a -> [(a,b)] -> b find nm pairs = head [ v | (n,v) <- pairs, n==nm] update :: Eq a => a -> b -> [(a,b)] -> [(a,b)] update nm value pairs = (nm,value) : [ (n,v) | (n,v) <- pairs, n /= nm ] getStore :: String -> (Store Map Value) getStore nm = St(\ s -> (find nm s,s)) putStore :: String -> Value -> (Store Map ()) putStore nm n = St(\ s -> ((),update nm n s)) --