/exercise3/NSWCAD.lhs

 1\begin{code}
 2
 3module NSWCAD where
 4
 5import Data.Maybe
 6import qualified DeBruijn as S
 7import qualified IntegerArithmetic as I
 8import Debug.Trace
 9
10data Value = BoolVal Bool | IntVal Integer | Clo S.Term Env
11  deriving Show
12
13type Env = [Value]
14
15evalInEnv :: Env -> S.Term -> Maybe Value
16evalInEnv e t = case t of
17  -- true,false
18	S.Tru -> Just (BoolVal True)
19	S.Fls -> Just (BoolVal False)
20  -- integer
21	S.IntConst n -> Just (IntVal n)
22  -- if
23	S.If t1 t2 t3 -> case evalInEnv e t1 of
24				Just (BoolVal True) -> case evalInEnv e t2 of
25							Just a -> Just a
26							_ -> error "if-t2"
27				Just (BoolVal False) -> case evalInEnv e t3 of
28							Just b -> Just b
29							_ -> error "if-t3"
30				_ -> error "if-t1"
31  -- var
32	S.Var i -> Just (e !! i)
33  -- app
34	S.App t1 t2 -> case evalInEnv e t1 of
35		Just (Clo (S.Abs tau t') e') -> case evalInEnv e t2 of
36						Just v' -> case evalInEnv ([v'] ++ e') t' of
37								Just vv -> Just vv
38								_ -> error "app-replacement"
39						_ -> error "app-t2 is not a value"
40		Just (Clo (S.Fix t') e') -> case evalInEnv e' (S.Fix t') of
41						Just (Clo (S.Abs tau' tt) ee) -> case evalInEnv e t2 of
42											Just v'-> case evalInEnv ([v']++ee) tt of
43													Just vv -> Just vv
44													_ -> Nothing
45											_ -> Nothing
46						_ -> Nothing
47		_ -> error "app-t1 is not an abstraction" 			
48  -- abs
49	S.Abs tau t1 -> Just (Clo (S.Abs tau t1) e)
50  -- add, sub,mul,div,nand
51	S.Bop op t1 t2 -> case evalInEnv e t1 of
52				Just (IntVal v1) -> case evalInEnv e t2 of
53							Just (IntVal v2) -> case op of
54									S.Add -> Just (IntVal (I.intAdd v1 v2))
55									S.Sub -> Just (IntVal (I.intSub v1 v2))
56									S.Mul -> Just (IntVal (I.intMul v1 v2))
57									S.Div -> Just (IntVal (I.intDiv v1 v2))
58									S.Nand -> Just (IntVal (I.intNand v1 v2))
59									
60							_ -> error "BOP t2 is not a value"
61				_ -> error "BOP t1 is not a value"
62  -- eq,lt
63	S.Bpr pr t1 t2 -> case evalInEnv e t1 of
64				Just (IntVal v1) -> case evalInEnv e t2 of
65							Just (IntVal v2) -> case pr of
66									S.Eq -> case I.intEq v1 v2 of
67										  True -> Just (BoolVal True)
68										  False -> Just (BoolVal False)
69										  
70									S.Lt -> case I.intLt v1 v2 of
71										  True -> Just (BoolVal True)
72										  False -> Just (BoolVal False)
73										  
74							_ -> error "BRP t2 is not a value"
75				_ -> error "BRP t1 is not a value"
76  -- let
77	S.Let t1 t2 -> case evalInEnv e t1 of
78				Just a -> case evalInEnv ([a] ++ e) t2 of
79						Just b -> Just b
80						_ -> error "let-t2 is not a value"
81				_ -> error "let t1 is not a value"
82  -- fix
83	S.Fix t1 -> case evalInEnv e t1 of
84			Just (Clo (S.Abs tau t') e') -> case evalInEnv ([Clo (S.Fix (S.Abs tau t')) e'] ++ e') t' of
85								Just b -> Just b
86								_ -> error "fix-point error"
87			_ -> error "fix-t1 is not an abstraction"
88
89
90eval :: S.Term -> Value
91eval t = fromJust (evalInEnv [] t)
92
93
94\end{code}