diff options
| -rw-r--r-- | app/Main.hs | 154 | ||||
| -rw-r--r-- | src/Lib.hs | 161 |
2 files changed, 158 insertions, 157 deletions
diff --git a/app/Main.hs b/app/Main.hs index 3509c47..6e1c43f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,127 +1,10 @@ -{-# LANGUAGE LambdaCase #-} - module Main ( main ) 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 +import Lib import System.Environment ( getArgs ) -data Term = Abs Term | App Term Term | Idx Int - deriving (Eq, Ord) - -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 ++ "]" - | (App l r) <- t = "(" ++ birbify l m ++ " " ++ birbify r m ++ ")" - | (Idx i) <- t = show i - -termify :: Map Birb Term -> String -> Term -termify m s = 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 - | 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 - filtered = filter (`Map.member` birbsies) s - term = termify birbsies filtered - in term - -fromTerm :: Term -> String -fromTerm t = - let flipped = (\(a, b) -> (b, a)) <$> birbs - 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 - main :: IO () -- main = mapM_ (bruteForce "...") [1 .. 10] main = do @@ -134,38 +17,3 @@ main = do let retermified = fromTerm normalBirbs putStrLn $ "reduced: " ++ retermified 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 = - [ ('\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', "!@!@1@00!@1@00") -- 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 - ] @@ -1,6 +1,159 @@ +{-# LANGUAGE LambdaCase #-} + module Lib - ( someFunc - ) where + ( 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) + +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 ++ "]" + | (App l r) <- t = "(" ++ birbify l m ++ " " ++ birbify r m ++ ")" + | (Idx i) <- t = show i + +termify :: Map Birb Term -> String -> Term +termify m s = 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 + | 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 + filtered = filter (`Map.member` birbsies) s + term = termify birbsies filtered + in term + +fromTerm :: Term -> String +fromTerm t = + let flipped = (\(a, b) -> (b, a)) <$> birbs + 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 + 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 -someFunc :: IO () -someFunc = putStrLn "someFunc" +birbs :: [(Birb, String)] +birbs = + [ ('\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', "!@!@1@00!@1@00") -- 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 + ] |