is a termreducer really worse than graph-reduction?

Author: thma

app/Main.hs

@@ -18,6 +18,7 @@ import System.TimeIt
 import Text.RawString.QQ
 import qualified Data.Bifunctor
 import LambdaToSKI (compileBracket)
+import TermReducer
 
 
 printGraph :: ST s (STRef s (Graph s)) -> ST s String
@@ -36,13 +37,16 @@ main = do
   hSetEncoding stdout utf8 -- this is required to handle UTF-8 characters like λ
 
   --let testSource = "main = (\\x y -> + x x) 3 4"
-  mapM_ showCompilations [prod, factorial, fibonacci, ackermann, tak]
+  mapM_ showCompilations [factorial, fibonacci, ackermann, tak]
   --demo
 
 type SourceCode = String
 
 prod :: SourceCode
-prod = "main = λx y. * x y"
+prod = [r| 
+  mult = λx y. * y x
+  main = mult 3 (+ 5 7)
+|]
 
 tak :: SourceCode
 tak = [r| 
@@ -110,6 +114,9 @@ showCompilations source = do
   print expr'
   printCS expr'
   putStrLn ""
+  --putStr "reduced: " 
+  --x <- red expr'
+  --print x
 
   let expr'' = compileBulk env
   putStrLn "The main expression compiled to SICKBY combinator expressions with bulk combinators:"

lambda-ski.cabal

@@ -34,6 +34,7 @@ library
       Kiselyov
       LambdaToSKI
       Parser
+      TermReducer
   other-modules:
       Paths_lambda_ski
   hs-source-dirs:

src/CLTerm.hs

@@ -13,7 +13,7 @@ module CLTerm
 
 import Parser (Expr(..))
 
-data CL = Com Combinator | INT Integer | CL :@ CL
+data CL = Com Combinator | INT Integer | CL :@ CL deriving (Eq)
 
 instance Show CL where
   showsPrec :: Int -> CL -> ShowS

src/TermReducer.hs

@@ -0,0 +1,48 @@
+module TermReducer where
+
+import CLTerm
+
+
+-- data CL = Com Combinator | INT Integer | CL :@ CL
+
+reduce :: CL -> IO CL
+reduce (Com c) = pure $ Com c
+reduce (INT i) = pure $ INT i
+reduce (Com I :@ t) = pure t
+reduce (Com K :@ t :@ _) = pure t
+reduce (Com S :@ t :@ u :@ v) = pure $ (t :@ v) :@ (u :@ v)
+reduce (Com B :@ f :@ g :@ x) = pure $ f :@ (g :@ x)      -- B F G X = F (G X)
+reduce (Com C :@ t :@ u :@ v) = pure $ t :@ v :@ u
+reduce (Com Y :@ t) = pure $ t :@ (Com Y :@ t)
+reduce (Com P :@ t :@ u) = pure $ Com P :@ t :@ u
+reduce (Com R :@ t :@ u) =  pure $ Com R :@ t :@ u
+reduce (Com ADD :@ INT i :@ INT j) = pure $ INT (i + j)
+reduce (Com ADD :@ i :@ j) = do ri <- red i; rj <- red j; reduce (Com ADD :@ ri :@ rj)
+reduce (Com SUB :@ INT i :@ INT j) = pure $ INT (i - j)
+reduce (Com SUB :@ i :@ j) = do ri <- red i; rj <- red j; reduce (Com SUB :@ ri :@ rj)
+reduce (Com MUL :@ INT i :@ INT j) = pure $ INT (i * j)
+reduce (Com MUL :@ i :@ j) = do ri <- red i; rj <- red j; reduce (Com MUL :@ ri :@ rj)
+reduce (Com DIV :@ INT i :@ INT j) = pure $ INT (i `div` j)
+reduce (Com DIV :@ i :@ j) = do ri <- red i; rj <- red j; reduce (Com DIV :@ ri :@ rj)
+reduce (Com REM :@ INT i :@ INT j) = pure $ INT (i `rem` j)
+reduce (Com REM :@ i :@ j) = do ri <- red i; rj <- red j; reduce (Com REM :@ ri :@ rj)
+reduce (Com SUB1 :@ INT i) = pure $ INT (i - 1)
+reduce (Com SUB1 :@ i) = do ri <- red i; reduce (Com SUB1 :@ ri)
+reduce (Com EQL :@ INT i :@ INT j) = if i == j then pure $ INT 1 else pure $ INT 0
+reduce (Com EQL :@ i :@ j) = do ri <- red i; rj <- red j; reduce (Com EQL :@ ri :@ rj)
+reduce (Com GEQ :@ INT i :@ INT j) = if i >= j then pure $ INT 1 else pure $ INT 0
+reduce (Com GEQ :@ i :@ j) = do ri <- red i; rj <- red j;  reduce (Com GEQ :@ ri :@ rj)
+reduce (Com ZEROP :@ INT i) = if i == 0 then pure $ INT 1 else pure $ INT 0
+reduce (Com ZEROP :@ i) = do ri <- red i; reduce (Com ZEROP :@ ri)
+reduce (Com IF :@ (INT t) :@ u :@ v) = if t == 1 then red u else red v
+reduce (Com IF :@ t :@ u :@ v) = do rt <- red t; if rt == INT 1 then red u else red v
+reduce (Com B' :@ t :@ u :@ v) = pure $ t :@ (u :@ v)
+reduce (Com C' :@ t :@ u :@ v) = pure $ t :@ v :@ u
+reduce (Com S' :@ t :@ u :@ v) = pure $ (t :@ v) :@ (u :@ v)
+reduce (Com T :@ t) = reduce t
+reduce (t :@ u) = do rt <- red t; ru <- red u; reduce $ rt :@ ru
+
+red :: CL -> IO CL
+red x@(INT i) = do print x; pure x
+red x@(Com c) = do print x; pure x
+red x = do print x; red =<< reduce x