diff options
| author | Marvin Borner | 2023-09-11 21:51:40 +0200 |
|---|---|---|
| committer | Marvin Borner | 2023-09-11 21:51:40 +0200 |
| commit | 4f8619571a4ec823b020baf9bc11f76fb706897e (patch) | |
| tree | 4895c595b04dd23988f548f58766937503e31917 | |
| parent | 56a8b80899626e419aaeba2441f4a704ce06e265 (diff) | |
Parallel bruteforcer
| -rw-r--r-- | app/Main.hs | 66 | ||||
| -rw-r--r-- | birb.cabal | 11 | ||||
| -rw-r--r-- | package.yaml | 3 |
3 files changed, 54 insertions, 26 deletions
diff --git a/app/Main.hs b/app/Main.hs index 39e1642..68c08fd 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,13 +4,20 @@ 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 +import Data.IORef ( IORef + , modifyIORef + , newIORef + , readIORef + , writeIORef + ) import Data.Map ( Map ) import qualified Data.Map as Map import System.Environment ( getArgs ) @@ -35,8 +42,8 @@ birbify t m | t `Map.member` m = [Map.findWithDefault invalid t m] | (App l r) <- t = "(" ++ birbify l m ++ " " ++ birbify r m ++ ")" | (Idx i) <- t = show i -termify :: String -> Map Birb Term -> Term -termify s m = foldlr (odd $ length lst) lst +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 @@ -65,18 +72,20 @@ 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 t = do -- TODO: pointfree?? - i <- newIORef 100000000 - go i t +nf o = do -- TODO: pointfree?? + i <- newIORef 1000 + go i o where go :: IORef Integer -> Term -> IO Term go i t = do -- oracle readIORef i >>= \case - 0 -> do - putStrLn "💥 potential infinite loop, continue? [yn]" - getLine >>= \case - "y" -> writeIORef i (-2) >> re i t - _ -> return t + 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 @@ -91,7 +100,7 @@ fromBirbs :: String -> Term fromBirbs s = let birbsies = Map.fromList $ second parse <$> birbs filtered = filter (`Map.member` birbsies) s - term = termify filtered birbsies + term = termify birbsies filtered in term fromTerm :: Term -> String @@ -100,17 +109,30 @@ 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 + main :: IO () -main = do - args <- getArgs - file <- readFile (head args) - let birbified = fromBirbs file - let retermified = fromTerm birbified - putStrLn $ "input: " ++ retermified - normalBirbs <- nf birbified - let rebirbified = fromTerm normalBirbs - putStrLn $ "reduced: " ++ rebirbified - return () +main = mapM_ (bruteForce "!!@1@1@1@1@10") [1 .. 10] +-- main = do +-- args <- getArgs +-- file <- readFile (head args) +-- let termified = fromBirbs file +-- let rebirbified = fromTerm termified +-- putStrLn $ "input: " ++ rebirbified +-- normalBirbs <- nf termified +-- 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 @@ -30,7 +30,8 @@ library src ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - base >=4.7 && <5 + async + , base >=4.7 && <5 , containers default-language: Haskell2010 @@ -40,9 +41,10 @@ executable birb Paths_birb hs-source-dirs: app - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -O3 -fllvm build-depends: - base >=4.7 && <5 + async + , base >=4.7 && <5 , birb , containers default-language: Haskell2010 @@ -56,7 +58,8 @@ test-suite birb-test test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + async + , base >=4.7 && <5 , birb , containers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 5ea0704..c216c24 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,7 @@ description: Please see the README on GitHub at <https://github.com/gith dependencies: - base >= 4.7 && < 5 - containers +- async ghc-options: - -Wall @@ -44,6 +45,8 @@ executables: - -threaded - -rtsopts - -with-rtsopts=-N + - -O3 + - -fllvm dependencies: - birb |