repos / machines.hs.git

commit

796991e

parent

d12d51c

author

Evgenii Akentev

date

2024-09-05 10:15:08 +0400 +04

Add SEC machine

 1@@ -12,7 +12,9 @@ common warnings
 2 
 3 library
 4     import:           warnings
 5-    exposed-modules:  Krivine, CEK, SECD
 6+    exposed-modules:  Krivine,
 7+                      CEK,
 8+                      SECD, SEC
 9     build-depends:    base ^>=4.18.2.1
10     hs-source-dirs:   src
11     default-language: Haskell2010

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