diff options
| -rw-r--r-- | app/Main.hs | 21 | ||||
| -rw-r--r-- | birb.cabal | 3 | ||||
| -rw-r--r-- | src/Lib.hs | 14 | ||||
| -rw-r--r-- | src/Term.hs | 34 | ||||
| -rw-r--r-- | src/Transpile.hs | 8 | ||||
| -rw-r--r-- | src/Utils.hs | 7 |
6 files changed, 72 insertions, 15 deletions
diff --git a/app/Main.hs b/app/Main.hs index 6e1c43f..004d079 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,10 +4,21 @@ module Main import Lib import System.Environment ( getArgs ) +import Term +import Transpile -main :: IO () --- main = mapM_ (bruteForce "...") [1 .. 10] -main = do +transpile :: IO () +transpile = do + args <- getArgs + file <- readFile (head args) + let term = fromBLC file + putStrLn $ "input: " ++ show term + let ski = transpileSKI term + putStrLn $ "transpiled: " ++ show ski + return () + +reduce :: IO () +reduce = do args <- getArgs file <- readFile (head args) let termified = fromBirbs file @@ -17,3 +28,7 @@ main = do let retermified = fromTerm normalBirbs putStrLn $ "reduced: " ++ retermified return () + +main :: IO () +main = transpile +-- main = mapM_ (bruteForce "...") [1 .. 10] @@ -24,6 +24,9 @@ source-repository head library exposed-modules: Lib + Term + Transpile + Utils other-modules: Paths_birb hs-source-dirs: @@ -22,21 +22,11 @@ import Data.IORef ( IORef ) import Data.Map ( Map ) import qualified Data.Map as Map - -data Term = Abs Term | App Term Term | Idx Int - deriving (Eq, Ord) +import Term +import Utils type Birb = Char -invalid :: a -invalid = error "invalid program state" - -instance Show Term where - 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 ++ "]" diff --git a/src/Term.hs b/src/Term.hs new file mode 100644 index 0000000..081363d --- /dev/null +++ b/src/Term.hs @@ -0,0 +1,34 @@ +module Term + ( Term(..) + , fromBLC + ) where + +import Utils + +data Term = Abs Term | App Term Term | Idx Int + deriving (Eq, Ord) + +instance Show Term where + showsPrec _ (Abs body) = showString "[" . shows body . showString "]" + showsPrec _ (App lhs rhs) = + showString "(" . shows lhs . showString " " . shows rhs . showString ")" + showsPrec _ (Idx i) = shows i + +fromBLC' :: String -> (Term, String) +fromBLC' inp = case inp of + '0' : '0' : rst -> let (e, es) = fromBLC' rst in (Abs e, es) + '0' : '1' : rst -> + let (exp1, rst1) = fromBLC' rst + (exp2, rst2) = fromBLC' rst1 + in (App exp1 exp2, rst2) + '1' : _ : rst -> binaryBruijn rst + _ -> invalid + where + binaryBruijn rst = + let idx = length (takeWhile (== '1') inp) - 1 + in case rst of + "" -> (Idx idx, "") + _ -> (Idx idx, drop idx rst) + +fromBLC :: String -> Term +fromBLC = fst . fromBLC' diff --git a/src/Transpile.hs b/src/Transpile.hs new file mode 100644 index 0000000..2b8134f --- /dev/null +++ b/src/Transpile.hs @@ -0,0 +1,8 @@ +module Transpile + ( transpileSKI + ) where + +import Term + +transpileSKI :: Term -> SKI +transpileSKI t = t diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 0000000..ec5f9a7 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,7 @@ +module Utils + ( invalid + ) where + +invalid :: a +invalid = error "invalid program state" + |