Added unary/binary encoding suffixes

3 files changed, 51 insertions, 24 deletions

diff --git a/src/Binary.hs b/src/Binary.hs
index ad67b20..ac08ca7 100644
--- a/src/Binary.hs
+++ b/src/Binary.hs
@@ -18,7 +18,7 @@ toBinary :: Expression -> String
 toBinary (Bruijn      x        ) = (replicate (x + 1) '1') ++ "0"
 toBinary (Abstraction e        ) = "00" ++ toBinary e
 toBinary (Application exp1 exp2) = "01" ++ (toBinary exp1) ++ (toBinary exp2)
-toBinary _                       = error "invalid"
+toBinary _                       = invalidProgramState
 
 fromBinary' :: String -> (Expression, String)
 fromBinary' inp = case inp of
@@ -28,7 +28,7 @@ fromBinary' inp = case inp of
         (exp2, rst2) = fromBinary' rst1
     in  (Application exp1 exp2, rst2)
   '1' : _ : rst -> binaryBruijn rst
-  e             -> error $ "invalid: " <> e
+  _             -> invalidProgramState
  where
   binaryBruijn rst =
     let idx = (length $ takeWhile (== '1') $ inp) - 1
@@ -49,7 +49,7 @@ toBitString str = Bit.concat
     (\case
       '0' -> False
       '1' -> True
-      _   -> error "invalid bit"
+      _   -> invalidProgramState
     )
     str
   ]
diff --git a/src/Helper.hs b/src/Helper.hs
index a10fbee..98cdaea 100644
--- a/src/Helper.hs
+++ b/src/Helper.hs
@@ -181,11 +181,16 @@ listify [] = Abstraction (Abstraction (Bruijn 0))
 listify (e : es) =
   Abstraction (Application (Application (Bruijn 0) e) (listify es))
 
+binarify :: [Expression] -> Expression
+binarify []       = Bruijn 2
+binarify (e : es) = Application e (binarify es)
+
 encodeByte :: [Bool] -> Expression
-encodeByte bits = listify (map encodeBit bits)
+encodeByte bits = Abstraction $ Abstraction $ Abstraction $ binarify
+  (map encodeBit bits)
  where
-  encodeBit False = Abstraction (Abstraction (Bruijn 0))
-  encodeBit True  = Abstraction (Abstraction (Bruijn 1))
+  encodeBit False = Bruijn 0
+  encodeBit True  = Bruijn 1
 
 -- TODO: There must be a better way to do this :D
 encodeBytes :: Byte.ByteString -> Expression
@@ -211,12 +216,11 @@ unlistify (Abstraction (Application (Application (Bruijn 0) e) es)) =
 unlistify _ = Nothing
 
 decodeByte :: Expression -> Maybe [Bool]
-decodeByte (Abstraction (Abstraction (Bruijn 0))) = Just []
-decodeByte (Abstraction (Application (Application (Bruijn 0) (Abstraction (Abstraction (Bruijn 0)))) es))
-  = (:) <$> Just False <*> (decodeByte es)
-decodeByte (Abstraction (Application (Application (Bruijn 0) (Abstraction (Abstraction (Bruijn 1)))) es))
-  = (:) <$> Just True <*> (decodeByte es)
-decodeByte _ = Nothing
+decodeByte (Abstraction (Abstraction (Abstraction es))) = decodeByte es
+decodeByte (Application (Bruijn 0) es) = (:) <$> Just False <*> (decodeByte es)
+decodeByte (Application (Bruijn 1) es) = (:) <$> Just True <*> (decodeByte es)
+decodeByte (Bruijn 2                 ) = Just []
+decodeByte _                           = Nothing
 
 decodeStdout :: Expression -> Maybe String
 decodeStdout e = do
@@ -277,6 +281,22 @@ decimalToTernary n =
   gen n' =
     Application (Bruijn $ fromIntegral $ mod n' 3) (gen $ div (n' + 1) 3)
 
+-- Decimal to binary encoding
+decimalToBinary :: Integer -> Expression
+decimalToBinary n | n < 0     = decimalToBinary 0
+decimalToBinary n | otherwise = Abstraction $ Abstraction $ Abstraction $ gen n
+ where
+  gen 0  = Bruijn 2
+  gen n' = Application (Bruijn $ fromIntegral $ mod n' 2) (gen $ div n' 2)
+
+-- Decimal to unary (church) encoding
+decimalToUnary :: Integer -> Expression
+decimalToUnary n | n < 0     = decimalToUnary 0
+decimalToUnary n | otherwise = Abstraction $ Abstraction $ gen n
+ where
+  gen 0  = Bruijn 0
+  gen n' = Application (Bruijn 1) (gen (n' - 1))
+
 ternaryToDecimal :: Expression -> Maybe String
 ternaryToDecimal e = do
   res <- resolve e
diff --git a/src/Parser.hs b/src/Parser.hs
index 74c2585..676bf37 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -103,9 +103,9 @@ importPath = some $ oneOf "./_+-" <|> letterChar <|> digitChar
 
 parseAbstraction :: Parser Expression
 parseAbstraction = do
-  _ <- string "[" <?> "opening abstraction"
+  _ <- string "[" <?> "abstraction start"
   e <- parseExpression
-  _ <- string "]" <?> "closing abstraction"
+  _ <- string "]" <?> "abstraction end"
   pure $ Abstraction e
 
 parseBruijn :: Parser Expression
@@ -115,9 +115,16 @@ parseBruijn = do
 
 parseNumeral :: Parser Expression
 parseNumeral = do
-  num <- parens number <?> "signed number"
-  pure $ decimalToTernary num
+  _    <- string "(" <?> "number start"
+  num  <- number <?> "signed number"
+  base <- (try (oneOf "ubt") <|> return 't')
+  _    <- string ")" <?> "number end"
+  pure $ (f base) num
  where
+  f 't' = decimalToTernary
+  f 'b' = decimalToBinary
+  f 'u' = decimalToUnary
+  f _   = invalidProgramState
   sign :: Parser (Integer -> Integer)
   sign = (char '-' >> return negate) <|> (char '+' >> return id)
   nat :: Parser Integer
@@ -166,7 +173,7 @@ parseMixfix = do
  where -- TODO: Rethink this.
   prefixAsMixfix = MixfixExpression <$> parsePrefix
   prefixOperatorAsMixfix =
-    MixfixExpression . Function <$> (prefixOperator <* char '‣')
+    MixfixExpression . Function <$> prefixOperator <* char '‣'
   operatorAsMixfix  = MixfixOperator . MixfixFunction <$> some mixfixSome
   singletonAsMixfix = MixfixExpression <$> parseSingleton
 
@@ -240,7 +247,7 @@ parseDefine lvl = do
   e    <- parseExpression
   _    <- parseDefineType
   subs <-
-    (try $ newline *> (many (parseBlock (lvl + 1)))) <|> (try eof >> return [])
+    (try $ newline *> (many $ parseBlock $ lvl + 1)) <|> (try eof >> return [])
   pure $ ContextualInstruction (Define var e subs) inp
 
 parseReplDefine :: Parser Instruction
@@ -262,22 +269,22 @@ parseImport :: Parser Command
 parseImport = do
   _    <- string ":import" <* sc <?> "import instruction"
   path <- importPath
-  ns   <- (try $ (sc *> (namespace <|> string "."))) <|> (eof >> return "")
+  ns   <- (try $ sc *> (namespace <|> string ".")) <|> (eof >> return "")
   pure (Import (path ++ ".bruijn") ns)
 
 parseInput :: Parser Command
 parseInput = do
   _    <- string ":input" <* sc <?> "input instruction"
   path <- importPath
-  pure (Input $ path ++ ".bruijn")
+  pure $ Input $ path ++ ".bruijn"
 
 parseTest :: Parser Command
 parseTest = do
   _  <- string ":test" <* sc <?> "test"
-  e1 <- (parens parseExpression <?> "first expression")
+  e1 <- parens parseExpression <?> "first expression"
   sc
-  e2 <- (parens parseExpression <?> "second expression")
-  pure (Test e1 e2)
+  e2 <- parens parseExpression <?> "second expression"
+  pure $ Test e1 e2
 
 parseCommentBlock :: Parser Instruction
 parseCommentBlock = do
@@ -299,7 +306,7 @@ parseDefBlock :: Int -> Parser Instruction
 parseDefBlock lvl =
   (sepEndBy parseComment newline)
     *> string (replicate lvl '\t')
-    *> (try (parseDefine lvl))
+    *> (try $ parseDefine lvl)
 
 parseBlock :: Int -> Parser Instruction
 parseBlock lvl =