Oof

1 files changed, 55 insertions, 44 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 656247d..29f864e 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -10,7 +10,6 @@ import           Data.Char                      ( digitToInt
                                                 )
 import           Data.Map                       ( Map )
 import qualified Data.Map                      as Map
-import           Debug.Trace
 import           System.Environment             ( getArgs )
 
 data Term = Abs Term | App Term Term | Idx Int
@@ -21,32 +20,33 @@ type Birb = Char
 invalid :: a
 invalid = error "invalid program state"
 
-instance Read Term where
-  readsPrec _ s
-    | c : s' <- s, isDigit c
-    = [(Idx (digitToInt c), s')]
-    | '!' : s' <- s, [(t, s'')] <- reads s'
-    = [(Abs t, s'')]
-    | '@' : s' <- s, [(t, s'')] <- reads s', [(u, s''')] <- reads s''
-    = [(App t u, s''')]
-    | otherwise
-    = invalid
-
 instance Show Term where
-  showsPrec _ (Abs body   ) = showString "\\" . shows body
-  showsPrec _ (App lhs rhs) = showString "@" . shows lhs . shows rhs
-  showsPrec _ (Idx i      ) = shows i
+  showsPrec _ (Abs body) = showString "[" . shows body . showString "]"
+  showsPrec _ (App lhs rhs) =
+    showString "(" . shows lhs . showString " " . shows rhs . showString ")"
+  showsPrec _ (Idx i) = shows i
 
 birbify :: Term -> Map Term Birb -> String
 birbify t m | t `Map.member` m = [Map.findWithDefault invalid t m]
-            | (Abs a) <- t     = "\\" ++ birbify a m
-            | (App l r) <- t   = "@" ++ birbify l m ++ birbify r m
+            | (Abs a) <- t     = "[" ++ birbify a m ++ "]"
+            | (App l r) <- t   = "(" ++ birbify l m ++ " " ++ birbify r m ++ ")"
             | (Idx i) <- t     = show i
 
 termify :: String -> Map Birb Term -> Term
-termify [c     ] m = Map.findWithDefault invalid c m
-termify (c : cs) m = App (termify [c] m) (termify cs m)
-termify _        _ = invalid
+termify s m = foldlr (odd $ length lst) lst
+ where
+  go [c     ] = [Map.findWithDefault invalid c m]
+  go (c : cs) = go [c] ++ go cs
+  go _        = invalid
+  lst = go s
+
+  -- TODO: Rewrite so last/init aren't needed
+  foldlr :: Bool -> [Term] -> Term
+  foldlr _     [x]      = x
+  foldlr _     [x, y]   = App x y
+  foldlr True  xs       = let t = foldlr False (init xs) in App t (last xs)
+  foldlr False (x : xs) = let t = foldlr True xs in App x t
+  foldlr _     _        = invalid
 
 shift :: Int -> Term -> Term
 shift i (Idx j) | i <= j    = Idx $ j + 1
@@ -70,7 +70,7 @@ nf t       = t
 
 fromBirbs :: String -> Term
 fromBirbs s =
-  let birbsies = Map.fromList $ second read <$> trace (show birbs) birbs
+  let birbsies = Map.fromList $ second parse <$> birbs
       filtered = filter (`Map.member` birbsies) s
       term     = termify filtered birbsies
   in  nf term
@@ -78,7 +78,7 @@ fromBirbs s =
 fromTerm :: Term -> String
 fromTerm t =
   let flipped  = (\(a, b) -> (b, a)) <$> birbs
-      termsies = Map.fromList $ first read <$> trace (show flipped) flipped
+      termsies = Map.fromList $ first parse <$> flipped
   in  birbify t termsies
 
 main :: IO ()
@@ -86,30 +86,41 @@ main = do
   args <- getArgs
   file <- readFile (head args)
   let reduced = fromBirbs file
-  print reduced
-  let duced = fromTerm reduced
-  print duced
+  let duced   = fromTerm reduced
+  putStrLn duced
   return ()
 
+-- this isn't really relevant but I'm too lazy to type the terms manually
+parse :: String -> Term
+parse = fst . go
+ where
+  go ('!' : cs) = let (t, cs') = go cs in (Abs t, cs')
+  go ('@' : cs) =
+    let (l, cs' ) = go cs
+        (r, cs'') = go cs'
+    in  (App l r, cs'')
+  go (i : cs) | isDigit i = (Idx $ digitToInt i, cs)
+  go _                    = invalid
+
 birbs :: [(Birb, String)]
 birbs =
-  [ ('\x1FAB6', "!!!@@201")
-  , ('\x1F426', "!0")
-  , ('\x1F54A', "!!!!@@32@10")
-  , ('\x1F424', "!!@0@@110")
-  , ('\x1F425', "!!!@0@12")
-  -- , ('\x1F423', "!@00!@00") --
-  , ('\x1F989', "!!@0@10")
-  , ('\x1F414', "!@00")
-  , ('\x1F986', "!!1")
-  , ('\x1F9A4', "!!@01")
-  -- , ('\x1F9A9', "!!@1@00!@1@00") --
-  , ('\x1F9A2', "!!!@@20@10")
-  , ('\x1FABD', "!!!!@@3@20@10")
-  , ('\x1F983', "!!@@100")
-  , ('\x1F413', "!!!@@012")
-  , ('\x1F99A', "!!!@1@20")
-  , ('\x1F99C', "!!!@2@10")
-  , ('\x1F985', "!!!!!@@43@@210")
-  -- , ('\x1F427', "!0!!!@@20@10!!1") --
+  [ ('\x1F426', "!0") -- bird
+  , ('\x1F54A', "!!!!@@32@10") -- dove
+  , ('\x1F424', "!!@0@@110") -- chick
+  , ('\x1F425', "!!1") -- front chick
+  , ('\x1F423', "!!!@0@21") -- hatching chick
+  , ('\x1F989', "!!@0@10") -- owl
+  , ('\x1F986', "!!@0@12") -- duck
+  , ('\x1F9A4', "!!@01") -- dodo
+  , ('\x1F9A9', "!!!@@201") -- flamingo
+  , ('\x1F9A2', "!!!@@20@10") -- swan
+  , ('\x1FABD', "!!!!@@3@20@10") -- wing
+  , ('\x1F99A', "!!!@1@20") -- peacock
+  , ('\x1F99C', "!@00") -- parrot
+  , ('\x1F985', "!!!!!@@43@@210") -- eagle
+  , ('\x1F427', "!!!@2@10") -- penguin
+-- , ('\x1FAB6', "") -- feather
+-- , ('\x1F413', "") -- rooster
+-- , ('\x1F414', "") -- chicken
+-- , ('\x1F983', "") -- turkey
   ]