Finished transpiler

4 files changed, 34 insertions, 38 deletions

diff --git a/src/Lib.hs b/src/Lib.hs
index 558d9ec..0c6d1b4 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -3,11 +3,8 @@
 module Lib
   ( fromBirbs
   , fromTerm
-  , nf
   ) where
 
-import           Control.Concurrent.Async       ( mapConcurrently )
-import           Control.Monad                  ( void )
 import           Data.Bifunctor                 ( first
                                                 , second
                                                 )
@@ -56,18 +53,6 @@ fromTerm t =
       termsies = Map.fromList $ first parse <$> flipped
   in  birbify t termsies
 
-bruteForce :: String -> Integer -> IO ()
-bruteForce s n =
-  let combos    = mapM (const $ map fst birbs) [1 .. n]
-      birbsies  = Map.fromList $ second parse <$> birbs
-      termified = termify birbsies <$> combos
-      target    = parse s
-      huh t = nf t >>= \case
-        r | r == target -> putStrLn (fromTerm t)
-          | otherwise   -> return ()
-      go ts = void $ mapConcurrently huh ts
-  in  putStrLn ("trying " ++ show n) >> go termified
-
 -- this isn't really relevant but I'm too lazy to type the terms manually
 parse :: String -> Term
 parse = fst . go
@@ -88,7 +73,7 @@ birbs =
   , ('\x1F425', "!!1") -- front chick
   , ('\x1F423', "!!!@0@21") -- hatching chick
   , ('\x1F989', "!!@0@10") -- owl
-  , ('\x1F986', "!!@0@12") -- duck
+  , ('\x1F986', "!!!@0@12") -- duck
   , ('\x1F9A4', "!@!@1@00!@1@00") -- dodo
   , ('\x1F9A9', "!!!@@201") -- flamingo
   , ('\x1F9A2', "!!!@@20@10") -- swan
diff --git a/src/Term.hs b/src/Term.hs
index c5a4fa0..a84b6c5 100644
--- a/src/Term.hs
+++ b/src/Term.hs
@@ -7,12 +7,6 @@ module Term
   ) where
 
 import           Control.Concurrent.MVar
-import           Data.IORef                     ( IORef
-                                                , modifyIORef
-                                                , newIORef
-                                                , readIORef
-                                                , writeIORef
-                                                )
 import           Data.List                      ( elemIndex )
 import           Data.Map.Strict                ( Map )
 import qualified Data.Map.Strict               as Map
@@ -76,7 +70,6 @@ toRedex = convertWorker (NameGen 1) []
     in  Rapp lhs rhs
   convertWorker _ ns (Idx i) =
     Ridx $ Num (if i < 0 || i >= length ns then i else ns !! i)
-  convertWorker _ _ _ = invalid
 
 fromRedex :: Redex -> Term
 fromRedex = convertWorker []
diff --git a/src/Transpile.hs b/src/Transpile.hs
index 3c0c1dc..d1dc077 100644
--- a/src/Transpile.hs
+++ b/src/Transpile.hs
@@ -1,4 +1,4 @@
--- This code partly uses algorithms created by John Tromp.
+-- This code partly uses algorithms (drip/abstract) created by John Tromp.
 -- Since they did not license their code (afaik), I assume it's okay to reuse it.
 
 module Transpile
@@ -12,8 +12,14 @@ import           Utils
 data SKI = S | K | I | AppSKI SKI SKI | IdxSKI Int
   deriving (Eq, Ord)
 
-data Birb = Swan | Kool | Bird | Quacky
-  deriving (Eq, Ord, Show)
+data Birb = Swan | Kool | Idiot | Quacky
+  deriving (Eq, Ord)
+
+instance Show Birb where
+  showsPrec _ Swan   = showString "\x1F9A2"
+  showsPrec _ Kool   = showString "\x1F425"
+  showsPrec _ Idiot  = showString "\x1F426"
+  showsPrec _ Quacky = showString "\x1F986"
 
 instance Show SKI where
   showsPrec _ S = showString "s"
@@ -40,8 +46,7 @@ abstract e = if freeIn (== 0) e then occabstract e else AppSKI K (drip e) where
   isConst = not . freeIn (const True)
   occabstract (IdxSKI 0) = I
   occabstract (AppSKI m (IdxSKI 0)) | not (freeIn (== 0) m) = drip m
-  occabstract (AppSKI (AppSKI l m) l') | l == l' -- && freeIn (==0) e1
-                                                 =
+  occabstract (AppSKI (AppSKI l m) l') | l == l' =
     occabstract (AppSKI (AppSKI (AppSKI (AppSKI S S) K) l) m)
   occabstract (AppSKI m (AppSKI n l)) | isConst m && isConst n =
     occabstract (AppSKI (AppSKI (AppSKI S (abstract m)) n) l)
@@ -61,15 +66,29 @@ transpileSKI (Abs m  ) = abstract (transpileSKI m)
 fromSKI :: SKI -> Birb
 fromSKI S = Swan
 fromSKI K = Kool
-fromSKI I = Bird
+fromSKI I = Idiot
 fromSKI _ = invalid
 
+jotify :: SKI -> [Bool]
+jotify = reverse . go
+ where
+  go S            = [True, True, True, True, True, False, False, False]
+  go K            = [True, True, True, False, False]
+  go I            = go $ AppSKI (AppSKI S K) K
+  go (AppSKI a b) = True : (go a ++ go b)
+  go _            = invalid
+
+dejotify :: [Bool] -> SKI
+dejotify (False : js) = AppSKI (AppSKI (dejotify js) S) K
+dejotify (True  : js) = AppSKI S (AppSKI K (dejotify js))
+dejotify _            = I
+
 transpileBirb :: SKI -> [Birb]
-transpileBirb (AppSKI a b) = case [a, b] of
-  [AppSKI x l, AppSKI y r] -> invalid -- TODO
-  [AppSKI x l, r] -> [Bird, Bird] ++ transpileBirb x ++ [fromSKI a, fromSKI b]
-  [l, AppSKI r x] ->
-    [Bird, Quacky] ++ transpileBirb x ++ [fromSKI r, fromSKI l]
-  [l, r] -> [fromSKI l, fromSKI r]
-transpileBirb (IdxSKI _) = invalid
-transpileBirb s          = [fromSKI s]
+transpileBirb = go . dejotify . jotify
+ where
+  go (AppSKI a b) = case [a, b] of
+    [AppSKI x l, r] -> [Idiot, Idiot] ++ go x ++ [fromSKI l, fromSKI r]
+    [l, AppSKI r x] -> [Idiot, Quacky] ++ go x ++ [fromSKI r, fromSKI l]
+    [l, r] -> [fromSKI l, fromSKI r]
+  go (IdxSKI _) = invalid
+  go s          = [fromSKI s]
diff --git a/src/Utils.hs b/src/Utils.hs
index ec5f9a7..27ddb69 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -4,4 +4,3 @@ module Utils
 
 invalid :: a
 invalid = error "invalid program state"
-