From fd5db40c4d035706b23a929a64fe7e208abbce17 Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Thu, 5 Sep 2024 10:41:54 +0400 Subject: [PATCH] Add SE and EC --- machines.cabal | 2 +- src/EC.hs | 52 +++++++++++++++++++++++++++++++++++++++++++++++ src/SE.hs | 55 ++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 108 insertions(+), 1 deletion(-) create mode 100644 src/EC.hs create mode 100644 src/SE.hs diff --git a/machines.cabal b/machines.cabal index 8456e17..aa34dc1 100644 --- 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 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 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 -- 2.34.1