diff options
Diffstat (limited to 'src/Lib.hs')
| -rw-r--r-- | src/Lib.hs | 76 |
1 files changed, 3 insertions, 73 deletions
@@ -3,40 +3,21 @@ module Lib ( fromBirbs , fromTerm - , nf ) where -import Control.Concurrent.Async ( mapConcurrently ) -import Control.Monad ( void ) import Data.Bifunctor ( first , second ) import Data.Char ( digitToInt , isDigit ) -import Data.IORef ( IORef - , modifyIORef - , newIORef - , readIORef - , writeIORef - ) 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 ++ "]" @@ -59,45 +40,6 @@ termify m s = foldlr (odd $ length lst) lst 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 - | otherwise = Idx j -shift i (App a b) = App (shift i a) (shift i b) -shift i (Abs a ) = Abs (shift (i + 1) a) - -subst :: Int -> Term -> Term -> Term -subst i (Idx j) c | i == j = c - | j > i = Idx $ j - 1 - | otherwise = Idx j -subst i (App a b) c = App (subst i a c) (subst i b c) -subst i (Abs a ) c = Abs (subst (i + 1) a (shift 0 c)) - -nf :: Term -> IO Term -nf o = do -- TODO: pointfree?? - -- i <- newIORef 1000 - i <- newIORef 100000000 - go i o - where - go :: IORef Integer -> Term -> IO Term - go i t = do -- oracle - readIORef i >>= \case - -- 0 -> writeIORef i (-1) >> return (Idx 0) - 0 -> do - putStrLn "💥 potential infinite loop, continue? [yn]" - getLine >>= \case - "y" -> writeIORef i (-2) >> re i t - "n" -> writeIORef i (-1) >> return t - _ -> go i t - (-1) -> return t - _ -> modifyIORef i (subtract 1) >> re i t - - re :: IORef Integer -> Term -> IO Term - re i (App l r) = go i l >>= \case - Abs t -> go i (subst 0 t r) - t -> App t <$> go i r - re i (Abs t) = Abs <$> go i t - re _ t = pure t - fromBirbs :: String -> Term fromBirbs s = let birbsies = Map.fromList $ second parse <$> birbs @@ -111,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 @@ -143,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 |