repos / machines.hs.git

SE.hs

 1module Abstract.SE where
 2
 3-- https://www.brics.dk/RS/03/33/BRICS-RS-03-33.pdf
 4
 5data Term = Appl Term Term | Var String | Abst String Term | Lit Int
 6  deriving (Show)
 7
 8data Val = Num Int | Succ | Closure Term String Env
 9  deriving (Show)
10
11data Directive = DTerm Term | DApply
12
13type Stack = [Val]
14type Env = [(String, Val)]
15type Control = Stack -> Env -> Stack
16
17initEnv :: Env
18initEnv = [("succ", Succ)]
19
20eval :: (Term, Stack, Env) -> (Stack, Env)
21eval (Lit n, s, e) = ((Num n):s, e)
22eval (Var x, s, e) = case lookup x e of
23  Just v -> (v:s, e)
24  Nothing -> error "var not in scope"
25eval (Abst x t, s, e) = ((Closure t x e):s, e)
26eval (Appl t0 t1, s, e) =
27  let
28    (s', e') = eval (t1, s, e)
29    (s'', e'') = eval (t0, s', e')
30  in apply (s'', e'')
31
32apply :: (Stack, Env) -> (Stack, Env)
33apply (Succ : (Num n):s, e) = ((Num $ n + 1):s, e)
34apply ((Closure t x e'):v':s, e) =
35  let ([v], _) = eval (t, [], (x, v'):e') 
36  in (v:s, e)
37
38evaluate :: Term -> Val
39evaluate t =
40  let ([v], _) = eval (t, [], initEnv) 
41  in v
42
43-- (\ 0 0) (\ 0)
44t1 :: Term
45t1 = Appl (Abst "x" (Appl (Var "x") (Var "x"))) (Abst "x" (Appl (Var "succ") (Lit 1)))
46
47ex1 :: Val
48ex1 = evaluate t1
49
50--((λ 0) (λ 0)) (λ 0)
51t2 :: Term
52t2 = Appl (Appl (Abst "x" $ Var "x") (Abst "x" $ Var "x")) (Abst "x" $ Var "x")
53
54ex2 :: Val
55ex2 = evaluate t2