Add SE and EC

diff --git a/machines.cabal b/machines.cabal
index 8456e17dd3eefdf1ec4699e8acb9256cdb316584..aa34dc114e8122de1b8a3be8852cb87ac761bb15 100644 (file)
--- a/machines.cabal
+++ b/machines.cabal
@@ -14,7 +14,7 @@ library
     import:           warnings
     exposed-modules:  Krivine,
                       CEK,
-                      SECD, SEC
+                      SECD, SEC, SE, EC
     build-depends:    base ^>=4.18.2.1
     hs-source-dirs:   src
     default-language: Haskell2010

diff --git a/src/EC.hs b/src/EC.hs
new file mode 100644 (file)
index 0000000..d353fa5
--- /dev/null
+++ b/src/EC.hs
@@ -0,0 +1,52 @@
+module EC where
+
+-- https://www.brics.dk/RS/03/33/BRICS-RS-03-33.pdf
+
+data Term = Appl Term Term | Var String | Abst String Term | Lit Int
+  deriving (Show)
+
+data Val = Num Int | Succ | Closure Term String Env
+  deriving (Show)
+
+type Env = [(String, Val)]
+
+data Stackable = SEnv Env 
+               | STerm Term
+               | SVal Val
+
+type C = [Stackable]
+
+initEnv :: Env
+initEnv = [("succ", Succ)]
+
+runC :: (Val, Env, C) -> Val
+runC (v, e, []) = v
+runC (v, e, (SEnv e'):c) = runC (v, e', c)
+runC (v1, e, (STerm t0):c) = runT (t0, e, (SVal v1):c)
+runC (v0, e, (SVal v1):c) = runA (v0, v1, e, c)
+
+runT :: (Term, Env, C) -> Val
+runT (Lit n, e, c) = runC (Num n, e, c)
+runT (Var x, e, c) = case lookup x e of
+  Just v -> runC (v, e, c)
+  Nothing -> error "var is not in scope"
+runT (Abst x t, e, c) = runC (Closure t x e, e, c)
+runT (Appl t0 t1, e, c) = runT (t1, e, (STerm t0):c)
+
+runA :: (Val, Val, Env, C) -> Val 
+runA (Succ, Num n, e, c) = runC (Num $ n + 1, e, c)
+runA (Closure t x e', v, e, c) = runT (t, (x, v):e', (SEnv e):c)
+
+-- (\ 0 0) (\ 0)
+t1 :: Term
+t1 = Appl (Abst "x" (Appl (Var "x") (Var "x"))) (Abst "x" (Appl (Var "succ") (Lit 1)))
+
+ex1 :: Val
+ex1 = runT (t1, initEnv, [])
+
+--((λ 0) (λ 0)) (λ 0)
+t2 :: Term
+t2 = Appl (Appl (Abst "x" $ Var "x") (Abst "x" $ Var "x")) (Abst "x" $ Var "x")
+
+ex2 :: Val
+ex2 = runT (t2, initEnv, [])

diff --git a/src/SE.hs b/src/SE.hs
new file mode 100644 (file)
index 0000000..e4c8f7e
--- /dev/null
+++ b/src/SE.hs
@@ -0,0 +1,55 @@
+module SE where
+
+-- https://www.brics.dk/RS/03/33/BRICS-RS-03-33.pdf
+
+data Term = Appl Term Term | Var String | Abst String Term | Lit Int
+  deriving (Show)
+
+data Val = Num Int | Succ | Closure Term String Env
+  deriving (Show)
+
+data Directive = DTerm Term | DApply
+
+type Stack = [Val]
+type Env = [(String, Val)]
+type Control = Stack -> Env -> Stack
+
+initEnv :: Env
+initEnv = [("succ", Succ)]
+
+eval :: (Term, Stack, Env) -> (Stack, Env)
+eval (Lit n, s, e) = ((Num n):s, e)
+eval (Var x, s, e) = case lookup x e of
+  Just v -> (v:s, e)
+  Nothing -> error "var not in scope"
+eval (Abst x t, s, e) = ((Closure t x e):s, e)
+eval (Appl t0 t1, s, e) =
+  let
+    (s', e') = eval (t1, s, e)
+    (s'', e'') = eval (t0, s', e')
+  in apply (s'', e'')
+
+apply :: (Stack, Env) -> (Stack, Env)
+apply (Succ : (Num n):s, e) = ((Num $ n + 1):s, e)
+apply ((Closure t x e'):v':s, e) =
+  let ([v], _) = eval (t, [], (x, v'):e') 
+  in (v:s, e)
+
+evaluate :: Term -> Val
+evaluate t =
+  let ([v], _) = eval (t, [], initEnv) 
+  in v
+
+-- (\ 0 0) (\ 0)
+t1 :: Term
+t1 = Appl (Abst "x" (Appl (Var "x") (Var "x"))) (Abst "x" (Appl (Var "succ") (Lit 1)))
+
+ex1 :: Val
+ex1 = evaluate t1
+
+--((λ 0) (λ 0)) (λ 0)
+t2 :: Term
+t2 = Appl (Appl (Abst "x" $ Var "x") (Abst "x" $ Var "x")) (Abst "x" $ Var "x")
+
+ex2 :: Val
+ex2 = evaluate t2