From 6f905d443a6b3a6dc6a849601addf0b17dc6e202 Mon Sep 17 00:00:00 2001
From: Evgenii Akentev <hi@ak3n.com>
Date: Sat, 7 Sep 2024 22:05:41 +0400
Subject: [PATCH] Add Virtual CLS and SECD machines

---
 machines.cabal      |  2 ++
 src/Virtual/CLS.hs  | 46 +++++++++++++++++++++++++++++++++++++++++++++
 src/Virtual/SECD.hs | 46 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 94 insertions(+)
 create mode 100644 src/Virtual/CLS.hs
 create mode 100644 src/Virtual/SECD.hs

diff --git a/machines.cabal b/machines.cabal
index d35fc01..03cc676 100644
--- a/machines.cabal
+++ b/machines.cabal
@@ -23,6 +23,8 @@ library
                       Virtual.Krivine,
                       Virtual.CAM,
                       Virtual.VEC,
+                      Virtual.CLS,
+                      Virtual.SECD,
     build-depends:    base ^>=4.18.2.1
     hs-source-dirs:   src
     default-language: Haskell2010
diff --git a/src/Virtual/CLS.hs b/src/Virtual/CLS.hs
new file mode 100644
index 0000000..37e96cc
--- /dev/null
+++ b/src/Virtual/CLS.hs
@@ -0,0 +1,46 @@
+{-# language LambdaCase #-}
+
+module Virtual.CLS where
+
+-- From Interpreter to Compiler and
+-- Virtual Machine: A Functional Derivation
+-- https://pdfs.semanticscholar.org/08f9/c12239dd720cb28a1039db9ce706cc7ee3b2.pdf
+
+data Term = Var Int | Lam Term | App Term Term
+data Inst = Access Int | ILam [Inst] | Ap | Push
+  deriving (Show)
+type Env = [Val]
+data Val = Closure [Inst] Env 
+  deriving (Show)
+
+compile :: Term -> [Inst]
+compile = \case
+  (Var n) -> [Access n]
+  (Lam t) -> [ILam $ compile t]
+  (App t0 t1) -> Push : compile t0 ++ compile t1 ++ [Ap]
+
+
+step :: [Inst] -> [Env] -> [Val] -> Val
+step (Access 0 : c) ((v : _) : l) s = step c l (v : s) 
+step (Access n : c) ((_ : e) : l) s = step (Access (n - 1) : c) (e : l) s
+step (ILam c : c') (e : l) s = step c' l (Closure c e : s)
+step (Ap : c) l (v : (Closure c' e) : s) = step (c' ++ c) ((v : e) : l) s
+step (Push : c) (e : l) s = step c (e : e : l) s
+step [] _ (v : _) = v
+
+eval :: Term -> Val
+eval t = step  (compile t) [[]] []
+
+-- (\ 0 0) (\ 0)
+t1 :: Term
+t1 = App (Lam (App (Var 0) (Var 0))) (Lam (Var 0))
+
+ex1 :: Val
+ex1 = eval t1
+
+--((λ 0) (λ 0)) (λ 0)
+t2 :: Term
+t2 = App (App (Lam $ Var 0) (Lam $ Var 0)) (Lam $ Var 0)
+
+ex2 :: Val
+ex2 = eval t2
diff --git a/src/Virtual/SECD.hs b/src/Virtual/SECD.hs
new file mode 100644
index 0000000..c18507e
--- /dev/null
+++ b/src/Virtual/SECD.hs
@@ -0,0 +1,46 @@
+{-# language LambdaCase #-}
+
+module Virtual.SECD where
+
+-- From Interpreter to Compiler and
+-- Virtual Machine: A Functional Derivation
+-- https://pdfs.semanticscholar.org/08f9/c12239dd720cb28a1039db9ce706cc7ee3b2.pdf
+
+data Term = Var String | Lam String Term | App Term Term
+data Inst = Access String | Close String [Inst] | Call
+  deriving (Show)
+type Env = [(String, Val)]
+data Val = Closure String [Inst] Env 
+  deriving (Show)
+
+compile :: Term -> [Inst]
+compile = \case
+  (Var x) -> [Access x]
+  (Lam x t) -> [Close x $ compile t]
+  (App t0 t1) -> compile t1 ++ compile t0 ++ [Call]
+
+
+step :: [Inst] -> Env -> [Val] -> Val
+step (Access x : c) e s = case lookup x e of
+  Just v -> step c e (v:s)
+  Nothing -> error "Var not in scope"
+step (Close x c' : c) e s = step c e (Closure x c' e : s)
+step (Call : c) e (Closure x c' e' : v : s) = step (c' ++ c) ((x, v):e') s
+step [] e (v:_) = v
+
+eval :: Term -> Val
+eval t = step (compile t) [] []
+
+-- (\ 0 0) (\ 0)
+t1 :: Term
+t1 = App (Lam "x" (App (Var "x") (Var "x"))) (Lam "x" (Var "x"))
+
+ex1 :: Val
+ex1 = eval t1
+
+--((λ 0) (λ 0)) (λ 0)
+t2 :: Term
+t2 = App (App (Lam "x" $ Var "x") (Lam "x" $ Var "x")) (Lam "x" $ Var "x")
+
+ex2 :: Val
+ex2 = eval t2
-- 
2.34.1