Added higher order reducer

3 files changed, 42 insertions, 9 deletions

diff --git a/src/Reducer/HigherOrder.hs b/src/Reducer/HigherOrder.hs
new file mode 100644
index 0000000..91378b7
--- /dev/null
+++ b/src/Reducer/HigherOrder.hs
@@ -0,0 +1,40 @@
+-- MIT License, Copyright (c) 2024 Marvin Borner
+-- Slightly modified version of Tromp's AIT/Lambda.lhs reducer implementation
+module Reducer.HigherOrder
+  ( reduce
+  ) where
+
+import           Helper
+
+data HigherOrder = HigherOrderBruijn Int | HigherOrderAbstraction (HigherOrder -> HigherOrder) | HigherOrderApplication HigherOrder HigherOrder
+data NamedTerm = NamedVariable Int | NamedAbstraction Int NamedTerm | NamedApplication NamedTerm NamedTerm
+
+app :: HigherOrder -> HigherOrder -> HigherOrder
+app (HigherOrderAbstraction f) = f
+app f                          = HigherOrderApplication f
+
+eval :: Expression -> HigherOrder
+eval = go []
+ where
+  go env (Bruijn      x    ) = env !! x
+  go env (Abstraction e    ) = HigherOrderAbstraction $ \x -> go (x : env) e
+  go env (Application e1 e2) = app (go env e1) (go env e2)
+  go _   _                   = invalidProgramState
+
+toNamedTerm :: HigherOrder -> NamedTerm
+toNamedTerm = go 0
+ where
+  go _ (HigherOrderBruijn i) = NamedVariable i
+  go d (HigherOrderAbstraction f) =
+    NamedAbstraction d $ go (d + 1) (f (HigherOrderBruijn d))
+  go d (HigherOrderApplication e1 e2) = NamedApplication (go d e1) (go d e2)
+
+resolveExpression :: NamedTerm -> Expression
+resolveExpression = resolve []
+ where
+  resolve vs (NamedVariable i     ) = Bruijn $ vs !! i
+  resolve vs (NamedAbstraction v t) = Abstraction $ resolve (v : vs) t
+  resolve vs (NamedApplication l r) = Application (resolve vs l) (resolve vs r)
+
+reduce :: Expression -> Expression
+reduce = resolveExpression . toNamedTerm . eval
diff --git a/src/Reducer/ION.hs b/src/Reducer/ION.hs
index 9154bd8..5eb959b 100644
--- a/src/Reducer/ION.hs
+++ b/src/Reducer/ION.hs
@@ -147,7 +147,8 @@ rules ch vm = case chr' ch of
         let parentVal = load (load (sp vm1 + 1) vm1 + 1) vm1
         let (a, vm2)  = app (ord 'f') (load (sp vm1) vm1) vm1
         lazy 0 (wor a) (wor parentVal) (store (sp vm2) parentVal vm2)
-  _ -> error $ "invalid combinator " ++ show ch
+  '\0' -> store (sp vm) (arg' 1 vm) vm
+  _    -> error $ "invalid combinator " ++ show ch
   where lvm n f g = lazy n f g vm
 
 eval :: VM -> VM
diff --git a/src/Reducer/RKNL.hs b/src/Reducer/RKNL.hs
index 9513e38..5aa6ca1 100644
--- a/src/Reducer/RKNL.hs
+++ b/src/Reducer/RKNL.hs
@@ -2,7 +2,6 @@
 -- based on the RKNL abstract machine
 module Reducer.RKNL
   ( reduce
-  , unsafeReduce
   ) where
 
 import           Control.Concurrent.MVar
@@ -11,7 +10,6 @@ import           Data.Map.Strict                ( Map )
 import qualified Data.Map.Strict               as Map
 import           Data.Maybe                     ( fromMaybe )
 import           Helper
-import           System.IO.Unsafe               ( unsafePerformIO ) -- TODO: AAH
 
 type Store = Map Int Box
 type Stack = [Redex]
@@ -109,9 +107,3 @@ reduce e = do
   forEachState (loadTerm redex) transition >>= \case
     Cconf _ [] v -> pure $ fromRedex v
     _            -> invalidProgramState
-
--- TODO: AAAAAAAAAAAAAAAAH remove this
--- (probably not thaaat bad)
-{-# NOINLINE unsafeReduce #-}
-unsafeReduce :: Expression -> Expression
-unsafeReduce = unsafePerformIO . reduce