diff options
| -rw-r--r-- | README.md | 18 | ||||
| -rw-r--r-- | bruijn.cabal | 3 | ||||
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/Eval.hs | 259 | ||||
| -rw-r--r-- | src/Helper.hs | 2 | ||||
| -rw-r--r-- | src/Reducer.hs | 2 | ||||
| -rw-r--r-- | std/Byte.bruijn | 12 | ||||
| -rw-r--r-- | std/List.bruijn | 134 | ||||
| -rw-r--r-- | std/Number.bruijn | 20 | ||||
| -rw-r--r-- | std/Pair.bruijn | 12 | ||||
| -rw-r--r-- | std/String.bruijn | 29 |
11 files changed, 306 insertions, 186 deletions
@@ -26,7 +26,7 @@ Bruijn indices written in Haskell. turing-completeness isn’t a trivial [problem](https://cstheory.stackexchange.com/a/31321) in LC - Strongly opinionated parser with strict syntax rules -- Recursion can be implemented using combinators such as Y or ω +- Recursion can be implemented using combinators such as Y, Z or ω - Included standard library featuring many useful functions (see `std/`) @@ -135,15 +135,20 @@ understanding the logic of lambda calculus: get-one2 get-one # tests are similar to assertions in other languages + # they test equality using α-equivalence of reduced expressions # in this example they're used to show the reduced expressions - :test (get-one2) (+1) + :test (get-one2) ((+1)) + + # remember that numbers always need to be written in parenthesis + # therefore two braces are needed in tests because testing exprs + # must always be in parenthesis as well # indenting acts similarly to Haskell's where statement get-one3 foo bar (+1) foo bar - # equivalent of λx.x + # equivalent of λx.x or Haskell's id x = x id [0] # testing equivalent of (λx.x) (λx.λy.x) = λx.λy.x @@ -169,7 +174,7 @@ understanding the logic of lambda calculus: access-first [0 [[[0]]]] - :test (access-first number-set) (+1) + :test (access-first number-set) ((+1)) # ignore args and return string main ["Hello world!\n"] @@ -202,6 +207,9 @@ Some other great functions: :test (fst love) ([[[1]]]) :test (snd love) ([[[2]]]) + # you can also write (me : you) instead of (pair me you) + # also (^love) and (~love) instead of (fst love) and (snd love) + # numerical operations five --(((+8) + (-4)) - (-2)) @@ -214,7 +222,7 @@ Some other great functions: # lazy evaluation using infinite lists and indexing pow2 [(iterate (mul (+2)) (+1)) !! 0] - :test (pow2 (+5)) (+32) + :test (pow2 (+5)) ((+32)) # options :test (map inc (some (+1))) (some (+2)) diff --git a/bruijn.cabal b/bruijn.cabal index f866112..cd844b2 100644 --- a/bruijn.cabal +++ b/bruijn.cabal @@ -28,6 +28,7 @@ data-files: std/Option.bruijn std/Pair.bruijn std/Result.bruijn + std/String.bruijn source-repository head type: git @@ -46,7 +47,7 @@ library src default-extensions: LambdaCase - ghc-options: -Wall -Wextra -Werror -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints + ghc-options: -Wall -Wextra -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints build-depends: base >=4.7 && <5 , binary diff --git a/package.yaml b/package.yaml index 7ce52be..c0c6249 100644 --- a/package.yaml +++ b/package.yaml @@ -42,7 +42,6 @@ library: ghc-options: - -Wall - -Wextra - - -Werror - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Widentities diff --git a/src/Eval.hs b/src/Eval.hs index 9978a45..fdaa2cb 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -33,7 +33,8 @@ split _ [] = [] split [] x = map (: []) x split a@(_ : _) b@(c : _) | Just suffix <- a `stripPrefix` b = [] : split a suffix - | otherwise = if null rest then [[c]] else (c : head rest) : tail rest + | null rest = [[c]] + | otherwise = (c : head rest) : tail rest where rest = split a $ tail b -- TODO: Force naming convention for namespaces/files @@ -42,9 +43,17 @@ loadFile path conf = do f <- try $ readFile path :: IO (Either IOError String) case f of Left exception -> - print (ContextualError (ImportError $ show (exception :: IOError)) (Context "" $ nicePath conf)) >> pure (EnvState (Environment []) conf) - Right f' -> eval (filter (not . null) $ split "\n\n" f') - (EnvState (Environment []) (conf { isRepl = False, evalPaths = (path : (evalPaths conf)) })) + print + (ContextualError (ImportError $ show (exception :: IOError)) + (Context "" $ nicePath conf) + ) + >> pure (EnvState (Environment []) conf) + Right f' -> eval + (filter (not . null) $ split "\n\n" f') + (EnvState + (Environment []) + (conf { isRepl = False, evalPaths = (path : (evalPaths conf)) }) + ) evalVar :: String -> Environment -> Program (Failable Expression) evalVar var (Environment sub) = state $ \env@(Environment e) -> @@ -58,7 +67,8 @@ evalVar var (Environment sub) = state $ \env@(Environment e) -> evalAbs :: Expression -> Environment -> Program (Failable Expression) evalAbs e sub = evalExp e sub >>= pure . fmap Abstraction -evalApp :: Expression -> Expression -> Environment -> Program (Failable Expression) +evalApp + :: Expression -> Expression -> Environment -> Program (Failable Expression) evalApp f g sub = evalExp f sub >>= (\case @@ -66,19 +76,26 @@ evalApp f g sub = Right f' -> fmap (Application f') <$> evalExp g sub ) -evalInfix :: Expression -> String -> Expression -> Environment -> Program (Failable Expression) -evalInfix le i re = evalExp $ Application (Application (Variable $ "(" ++ i ++ ")") le) re +evalInfix + :: Expression + -> String + -> Expression + -> Environment + -> Program (Failable Expression) +evalInfix le i re = + evalExp $ Application (Application (Variable $ "(" ++ i ++ ")") le) re -evalPrefix :: String -> Expression -> Environment -> Program (Failable Expression) +evalPrefix + :: String -> Expression -> Environment -> Program (Failable Expression) evalPrefix p e = evalExp $ Application (Variable $ p ++ "(") e evalExp :: Expression -> Environment -> Program (Failable Expression) evalExp idx@(Bruijn _ ) = const $ pure $ Right idx evalExp ( Variable var) = evalVar var -evalExp ( Abstraction e) = evalAbs e +evalExp ( Abstraction e ) = evalAbs e evalExp ( Application f g) = evalApp f g -evalExp (Infix le i re) = evalInfix le i re -evalExp (Prefix p e) = evalPrefix p e +evalExp ( Infix le i re ) = evalInfix le i re +evalExp ( Prefix p e ) = evalPrefix p e evalDefine :: String -> Expression -> Environment -> Program (Failable Expression) @@ -87,11 +104,15 @@ evalDefine name e sub = >>= (\case Left e' -> pure $ Left e' Right f -> - modify (\(Environment s) -> Environment $ ((name, f), Environment []) : s) + modify + (\(Environment s) -> + Environment $ ((name, f), Environment []) : s + ) >> pure (Right f) ) -evalTest :: Expression -> Expression -> Environment -> Program (Failable Instruction) +evalTest + :: Expression -> Expression -> Environment -> Program (Failable Instruction) evalTest e1 e2 sub = evalExp e1 sub >>= (\case @@ -102,7 +123,8 @@ evalTest e1 e2 sub = evalSubEnv :: [Instruction] -> EnvState -> IO EnvState evalSubEnv [] s = return s evalSubEnv (instr : is) s = - handleInterrupt (putStrLn "<aborted>" >> return s) $ evalInstruction instr s (evalSubEnv is) + handleInterrupt (putStrLn "<aborted>" >> return s) + $ evalInstruction instr s (evalSubEnv is) fullPath :: String -> IO String fullPath path = do @@ -111,72 +133,85 @@ fullPath path = do pure $ if exists then lib else path evalInstruction - :: Instruction - -> EnvState - -> (EnvState -> IO EnvState) - -> IO EnvState -evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf) rec = case instr of - Define name e sub -> do - EnvState subEnv _ <- evalSubEnv sub s - let - (res, env') = evalDefine name e subEnv `runState` env - in case res of - Left err -> print (ContextualError err $ Context inp $ nicePath conf) >> pure s -- don't continue - Right _ -> if isRepl conf - then (putStrLn $ name <> " = " <> show e) - >> return (EnvState env' conf) - else rec (EnvState env' conf) - Input path -> do - full <- fullPath path - if full `elem` evalPaths conf then print (ContextualError (ImportError path) (Context inp $ nicePath conf)) >> pure s else do - EnvState env' conf' <- loadFile full (conf { nicePath = path }) -- TODO: Fix wrong `within` in import error - conf'' <- pure $ conf { tested = path : (tested conf' <> tested conf) } - rec (EnvState (env' <> env) conf'') -- import => isRepl = False - -- TODO: Don't import subimports into main env - Import path namespace -> do - full <- fullPath path - if full `elem` evalPaths conf then print (ContextualError (ImportError path) (Context inp $ nicePath conf)) >> pure s else do - EnvState env' conf' <- loadFile full (conf { nicePath = path }) -- TODO: Fix wrong `within` in import error - conf'' <- pure $ conf { tested = path : (tested conf') } - let prefix | null namespace = takeBaseName path ++ "." - | namespace == "." = "" - | otherwise = namespace ++ "." - env'' <- pure $ Environment $ map (\((n, e), o) -> ((prefix ++ n, e), o)) - ((\(Environment e) -> e) env') -- TODO: Improve - rec (EnvState (env'' <> env) conf'') -- import => isRepl = False - Evaluate e -> - let (res, _) = evalExp e (Environment []) `runState` env - in putStrLn - (case res of - Left err -> show err - Right e' -> - "<> " - <> (show e') - <> "\n*> " - <> (show reduced) - <> " " - <> (humanifyExpression reduced) - <> " " - <> (matchingFunctions reduced env) - where reduced = reduce e' - ) - >> rec s - Test e1 e2 -> if evalTests conf && (nicePath conf) `notElem` (tested conf) then - let (res, _) = evalTest e1 e2 (Environment []) `runState` env - in case res of - Left err -> print (ContextualError err $ Context inp $ nicePath conf) >> pure s - Right (Test e1' e2') -> - when - (lhs /= rhs) - (print $ FailedTest e1 e2 lhs rhs) - >> print (nicePath conf) >> print (e1) >> rec s - where - lhs = reduce e1' - rhs = reduce e2' - _ -> rec s - else rec s - _ -> rec s -evalInstruction instr s rec = evalInstruction (ContextualInstruction instr "<unknown>") s rec + :: Instruction -> EnvState -> (EnvState -> IO EnvState) -> IO EnvState +evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf) rec = + case instr of + Define name e sub -> do + EnvState subEnv _ <- evalSubEnv sub s + (res, env') <- pure $ evalDefine name e subEnv `runState` env + case res of + Left err -> + print (ContextualError err $ Context inp $ nicePath conf) >> pure s -- don't continue + Right _ + | isRepl conf -> (putStrLn $ name <> " = " <> show e) + >> return (EnvState env' conf) + | otherwise -> rec $ EnvState env' conf + Input path -> do + full <- fullPath path + if full `elem` evalPaths conf + then + print + (ContextualError (ImportError path) (Context inp $ nicePath conf)) + >> pure s + else do + EnvState env' conf' <- loadFile full (conf { nicePath = path }) -- TODO: Fix wrong `within` in import error + conf'' <- pure + $ conf { tested = path : (tested conf' <> tested conf) } + rec $ EnvState (env' <> env) conf'' -- import => isRepl = False + -- TODO: Don't import subimports into main env + Import path namespace -> do + full <- fullPath path + if full `elem` evalPaths conf + then + print + (ContextualError (ImportError path) (Context inp $ nicePath conf)) + >> pure s + else do + EnvState env' conf' <- loadFile full (conf { nicePath = path }) -- TODO: Fix wrong `within` in import error + conf'' <- pure $ conf { tested = path : (tested conf') } + let prefix | null namespace = takeBaseName path ++ "." + | namespace == "." = "" + | otherwise = namespace ++ "." + env'' <- pure $ Environment $ map + (\((n, e), o) -> ((prefix ++ n, e), o)) + ((\(Environment e) -> e) env') -- TODO: Improve + rec $ EnvState (env'' <> env) conf'' -- import => isRepl = False + Evaluate e -> + let (res, _) = evalExp e (Environment []) `runState` env + in putStrLn + (case res of + Left err -> show err + Right e' -> + "<> " + <> (show e') + <> "\n*> " + <> (show reduced) + <> " " + <> (humanifyExpression reduced) + <> " " + <> (matchingFunctions reduced env) + where reduced = reduce e' + ) + >> rec s + Test e1 e2 + | evalTests conf && (nicePath conf) `notElem` (tested conf) + -> let (res, _) = evalTest e1 e2 (Environment []) `runState` env + in + case res of + Left err -> + print (ContextualError err $ Context inp $ nicePath conf) + >> pure s + Right (Test e1' e2') -> + when (lhs /= rhs) (print $ FailedTest e1 e2 lhs rhs) >> rec s + where + lhs = reduce e1' + rhs = reduce e2' + _ -> rec s + | otherwise + -> rec s + _ -> rec s +evalInstruction instr s rec = + evalInstruction (ContextualInstruction instr "<unknown>") s rec eval :: [String] -> EnvState -> IO EnvState eval [] s = return s @@ -184,46 +219,65 @@ eval [""] s = return s eval (block : bs) s@(EnvState _ conf) = handleInterrupt (putStrLn "<aborted>" >> return s) $ case parse blockParser "" block of - Left err -> print (ContextualError (SyntaxError $ printBundle err) (Context "" $ nicePath conf)) >> eval bs s + Left err -> + print + (ContextualError (SyntaxError $ printBundle err) + (Context "" $ nicePath conf) + ) + >> eval bs s Right instr -> evalInstruction instr s (eval bs) - where blockParser = if isRepl conf then parseReplLine else parseBlock 0 + where + blockParser | isRepl conf = parseReplLine + | otherwise = parseBlock 0 evalMainFunc :: Environment -> Expression -> Maybe Expression evalMainFunc (Environment env) arg = do e <- lookup "main" (map fst env) pure $ reduce $ Application e arg -evalFileConf :: String -> (a -> IO ()) -> (Expression -> a) -> EvalConf -> ExpCache -> IO () -evalFileConf path wr conv conf cache = do - EnvState env _ _ <- loadFile path conf cache - arg <- encodeStdin +evalFileConf + :: String -> (a -> IO ()) -> (Expression -> a) -> EvalConf -> IO () +evalFileConf path wr conv conf = do + EnvState env _ <- loadFile path conf + arg <- encodeStdin case evalMainFunc env arg of - Nothing -> print $ ContextualError (UndeclaredFunction "main") (Context "" path) + Nothing -> + print $ ContextualError (UndeclaredFunction "main") (Context "" path) Just e -> wr $ conv e defaultConf :: String -> EvalConf -defaultConf path = EvalConf { isRepl = False, evalTests = True, nicePath = path, tested = [], evalPaths = [] } +defaultConf path = EvalConf { isRepl = False + , evalTests = True + , nicePath = path + , tested = [] + , evalPaths = [] + } reduceFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO () reduceFile path wr conv = do - EnvState (Environment env) _ _ <- loadFile path (defaultConf path) H.empty + EnvState (Environment env) _ <- loadFile path (defaultConf path) case lookup "main" (map fst env) of - Nothing -> print $ ContextualError (UndeclaredFunction "main") (Context "" path) + Nothing -> + print $ ContextualError (UndeclaredFunction "main") (Context "" path) Just e -> wr $ conv e evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO () -evalFile path wr conv = evalFileConf path wr conv (defaultConf path) H.empty +evalFile path wr conv = evalFileConf path wr conv (defaultConf path) -- TODO: Merge with evalFile evalYolo :: String -> (a -> IO ()) -> (Expression -> a) -> IO () -evalYolo path wr conv = evalFileConf path wr conv (defaultConf path) { evalTests = False } H.empty +evalYolo path wr conv = + evalFileConf path wr conv (defaultConf path) { evalTests = False } exec :: String -> (String -> IO (Either IOError a)) -> (a -> String) -> IO () exec path rd conv = do - f <- rd path + f <- rd path + arg <- encodeStdin case f of Left exception -> print (exception :: IOError) - Right f' -> putStr $ humanifyExpression $ reduce' $ Application (fromBinary $ conv f') arg + Right f' -> putStr $ humanifyExpression $ reduce $ Application + (fromBinary $ conv f') + arg repl :: EnvState -> InputT M () repl (EnvState env conf) = @@ -258,12 +312,17 @@ runRepl = do history <- getDataFileName "history" prefs <- readPrefs config let -- TODO: Use -y in repl for YOLO lifestyle - conf = EvalConf { isRepl = True, evalTests = True, nicePath = "<repl>", tested = [], evalPaths = [] } - looper = runInputTWithPrefs + conf = EvalConf { isRepl = True + , evalTests = True + , nicePath = "<repl>" + , tested = [] + , evalPaths = [] + } + looper = runInputTWithPrefs prefs (completionSettings history) - (withInterrupt $ repl $ EnvState (Environment []) conf H.empty) - code <- StrictState.evalStateT looper (EnvState (Environment []) conf H.empty) + (withInterrupt $ repl $ EnvState (Environment []) conf) + code <- StrictState.evalStateT looper (EnvState (Environment []) conf) return code usage :: IO () @@ -287,8 +346,8 @@ evalMain = do case args of [] -> runRepl ["-b", path] -> reduceFile path - (Byte.putStr . Bit.realizeBitStringStrict) - (toBitString . toBinary) + (Byte.putStr . Bit.realizeBitStringStrict) + (toBitString . toBinary) ["-B", path] -> reduceFile path putStrLn toBinary ["-e", path] -> exec path (try . Byte.readFile) (fromBitString . Bit.bitString) diff --git a/src/Helper.hs b/src/Helper.hs index afae9da..418735e 100644 --- a/src/Helper.hs +++ b/src/Helper.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} --- these extensions are only used because of printBundle from megaparsec +-- extensions above are only used because of printBundle from megaparsec module Helper where diff --git a/src/Reducer.hs b/src/Reducer.hs index ddf2439..7ba5845 100644 --- a/src/Reducer.hs +++ b/src/Reducer.hs @@ -24,7 +24,7 @@ import Helper bind :: Expression -> Expression -> Int -> Expression bind e (Bruijn x ) n = if x == n then e else Bruijn x bind e (Application e1 e2) n = Application (bind e e1 n) (bind e e2 n) -bind e (Abstraction exp' ) n = Abstraction (bind (e <-> (-1)) exp' (succ n)) +bind e (Abstraction exp' ) n = Abstraction $ bind (e <-> (-1)) exp' (succ n) bind _ _ _ = error "invalid" step :: Expression -> Expression diff --git a/std/Byte.bruijn b/std/Byte.bruijn index 3dd8c63..8d75314 100644 --- a/std/Byte.bruijn +++ b/std/Byte.bruijn @@ -1,6 +1,6 @@ # MIT License, Copyright (c) 2022 Marvin Borner -:import std/Combinator . +:import std/Logic . :import std/List . @@ -10,5 +10,15 @@ b0 false # bit 1 b1 true +# returns true if two bytes are equal +eq? &&( .. (zip-with xnor?) + +(=?) eq? + +:test ('a' =? 'a') (true) +:test ('a' =? 'b') (false) + # generates a byte with correct endianness byte [[[[[[[[0 : (1 : (2 : (3 : (4 : (5 : (6 : (7 : empty)))))))]]]]]]]] + +:test (byte b0 b1 b1 b0 b0 b0 b0 b1) ('a') diff --git a/std/List.bruijn b/std/List.bruijn index 8683a43..b84f5d0 100644 --- a/std/List.bruijn +++ b/std/List.bruijn @@ -12,7 +12,7 @@ # empty list element empty false -# returns whether a list is empty +# returns true if a list is empty empty? [0 [[[false]]] true] <>?( empty? @@ -26,7 +26,6 @@ cons P.pair (:) cons :test ((+1) : ((+2) : empty)) (P.pair (+1) (P.pair (+2) empty)) -:test ('a' : ('b' : ('c' : empty))) ("abc") # returns the head of a list or empty head P.fst @@ -43,11 +42,10 @@ tail P.snd :test (~((+1) : ((+2) : empty))) ((+2) : empty) # returns the length of a list in balanced ternary -length Z [[[case-some]]] case-empty - case-some <>?0 case-end case-inc +length Z [[[rec]]] (+0) + rec <>?0 case-end case-inc case-inc 2 ++1 ~0 case-end 1 - case-empty (+0) #( length @@ -55,8 +53,8 @@ length Z [[[case-some]]] case-empty :test (#empty) ((+0)) # returns the element at index in list -index Z [[[case-some]]] - case-some <>?0 case-end case-index +index Z [[[rec]]] + rec <>?0 case-end case-index case-index =?1 ^0 (2 --1 ~0) case-end empty @@ -68,26 +66,25 @@ index Z [[[case-some]]] :test (((+1) : ((+2) : ((+3) : empty))) !! (+3)) (empty) # applies a left fold on a list -foldl Z [[[[case-some]]]] - case-some <>?0 case-end case-fold +foldl Z [[[[rec]]]] + rec <>?0 case-end case-fold case-fold 3 2 (2 1 ^0) ~0 case-end 1 -:test ((foldl add (+0) ((+1) : ((+2) : ((+3) : empty)))) =? (+6)) (true) -:test ((foldl sub (+6) ((+1) : ((+2) : ((+3) : empty)))) =? (+0)) (true) +:test ((foldl (+) (+0) ((+1) : ((+2) : ((+3) : empty)))) =? (+6)) (true) +:test ((foldl (-) (+6) ((+1) : ((+2) : ((+3) : empty)))) =? (+0)) (true) # foldl without starting value foldl1 [[foldl 1 ^0 ~0]] # applies a right fold on a list -foldr [[[Z [[case-some]] case-empty]]] - case-some <>?0 case-end case-fold +foldr [[[Z [[rec]] 0]]] + rec <>?0 case-end case-fold case-fold 4 ^0 (1 ~0) case-end 3 - case-empty 0 -:test ((foldr add (+0) ((+1) : ((+2) : ((+3) : empty)))) =? (+6)) (true) -:test ((foldr sub (+2) ((+1) : ((+2) : ((+3) : empty)))) =? (+0)) (true) +:test ((foldr (+) (+0) ((+1) : ((+2) : ((+3) : empty)))) =? (+6)) (true) +:test ((foldr (-) (+2) ((+1) : ((+2) : ((+3) : empty)))) =? (+0)) (true) # foldr without starting value foldr1 [[foldl 1 ^0 ~0]] @@ -118,7 +115,7 @@ product foldl mul (+1) :test (Π ((+1) : ((+2) : ((+3) : empty)))) ((+6)) # adds all values in list -sum foldl add (+0) +sum foldl (+) (+0) Σ sum @@ -146,8 +143,8 @@ reverse foldl \cons empty list [0 [[[2 (0 : 1)]]] reverse empty] # appends two lists -append Z [[[case-some]]] - case-some <>?1 case-end case-merge +append Z [[[rec]]] + rec <>?1 case-end case-merge case-merge ^1 : (2 ~1 0) case-end 0 @@ -164,8 +161,8 @@ snoc [[1 ++ (0 : empty)]] :test (((+1) : empty) ; (+2)) ((+1) : ((+2) : empty)) # maps each element to a function -map Z [[[case-some]]] - case-some <>?0 case-end case-map +map Z [[[rec]]] + rec <>?0 case-end case-map case-map (1 ^0) : (2 1 ~0) case-end empty @@ -174,8 +171,8 @@ map Z [[[case-some]]] :test (inc <$> ((+1) : ((+2) : ((+3) : empty)))) ((+2) : ((+3) : ((+4) : empty))) # filters a list based on a predicate -filter Z [[[case-some]]] - case-some <>?0 case-end case-filter +filter Z [[[rec]]] + rec <>?0 case-end case-filter case-filter 1 ^0 (cons ^0) I (2 1 ~0) case-end empty @@ -184,8 +181,8 @@ filter Z [[[case-some]]] :test (((+1) : ((+0) : ((+3) : empty))) <#> zero?) ((+0) : empty) # returns the last element of a list -last Z [[case-some]] - case-some <>?0 case-end case-last +last Z [[rec]] + rec <>?0 case-end case-last case-last <>?(~0) ^0 (1 ~0) case-end empty @@ -194,8 +191,8 @@ _( last :test (last ((+1) : ((+2) : ((+3) : empty)))) ((+3)) # returns everything but the last element of a list -init Z [[case-some]] - case-some <>?0 case-end case-init +init Z [[rec]] + rec <>?0 case-end case-init case-init <>?(~0) empty (^0 : (1 ~0)) case-end empty @@ -214,61 +211,75 @@ concat-map [foldr (append . 0) empty] :test (concat-map [-0 : (0 : empty)] ((+1) : ((+2) : empty))) ((-1) : ((+1) : ((-2) : ((+2) : empty)))) # zips two lists discarding excess elements -zip Z [[[case-some]]] - case-some <>?1 case-end case-zip +zip Z [[[rec]]] + rec <>?1 case-end case-zip case-zip <>?0 empty ((^1 : ^0) : (2 ~1 ~0)) case-end empty :test (zip ((+1) : ((+2) : empty)) ((+2) : ((+1) : empty))) (((+1) : (+2)) : (((+2) : (+1)) : empty)) # applies pairs of the zipped list as arguments to a function -zip-with Z [[[[case-some]]]] - case-some <>?1 case-end case-zip +zip-with Z [[[[rec]]]] + rec <>?1 case-end case-zip case-zip <>?0 empty ((2 ^1 ^0) : (3 2 ~1 ~0)) case-end empty -:test (zip-with add ((+1) : ((+2) : empty)) ((+2) : ((+1) : empty))) ((+3) : ((+3) : empty)) +:test (zip-with (+) ((+1) : ((+2) : empty)) ((+2) : ((+1) : empty))) ((+3) : ((+3) : empty)) # returns first n elements of a list -take Z [[[case-some]]] - case-some <>?0 case-end case-take +take Z [[[rec]]] + rec <>?0 case-end case-take case-take =?1 empty (^0 : (2 --1 ~0)) case-end empty :test (take (+2) ((+1) : ((+2) : ((+3) : empty)))) ((+1) : ((+2) : empty)) # takes elements while a predicate is satisfied -take-while Z [[[case-some]]] - case-some <>?0 case-end case-take +take-while Z [[[rec]]] + rec <>?0 case-end case-take case-take 1 ^0 (^0 : (2 1 ~0)) empty case-end empty :test (take-while zero? ((+0) : ((+0) : ((+1) : empty)))) ((+0) : ((+0) : empty)) # removes first n elements of a list -drop Z [[[case-some]]] - case-some <>?0 case-end case-drop +drop Z [[[rec]]] + rec <>?0 case-end case-drop case-drop =?1 0 (2 --1 ~0) case-end empty :test (drop (+2) ((+1) : ((+2) : ((+3) : empty)))) ((+3) : empty) # removes elements from list while a predicate is satisfied -drop-while Z [[[case-some]]] - case-some <>?0 case-end case-drop +drop-while Z [[[rec]]] + rec <>?0 case-end case-drop case-drop 1 ^0 (2 1 ~0) 0 case-end empty :test (drop-while zero? ((+0) : ((+0) : ((+1) : empty)))) ((+1) : empty) +# returns pair of take-while and drop-while +span Z [[[rec]]] + rec <>?0 case-end case-drop + case-drop 1 ^0 ((^0 : ^recced) : ~recced) (empty : 0) + recced 2 1 ~0 + case-end empty : empty + +:test (span (\(<?) (+3)) ((+1) : ((+2) : ((+4) : ((+1) : empty))))) (((+1) : ((+2) : empty)) : ((+4) : ((+1) : empty))) + +# same as span but with inverted predicate +break [span (not! . 0)] + +:test (break (\(>?) (+3)) ((+1) : ((+2) : ((+4) : ((+1) : empty))))) (((+1) : ((+2) : empty)) : ((+4) : ((+1) : empty))) + # returns true if any element in a list matches a predicate -any? [lor? . (map 0)] +any? [||( . (map 0)] :test (any? (\gre? (+2)) ((+1) : ((+2) : ((+3) : empty)))) (true) :test (any? (\gre? (+2)) ((+1) : ((+2) : ((+2) : empty)))) (false) # returns true if all elements in a list match a predicate -all? [land? . (map 0)] +all? [&&( . (map 0)] :test (all? (\gre? (+2)) ((+3) : ((+4) : ((+5) : empty)))) (true) :test (all? (\gre? (+2)) ((+4) : ((+3) : ((+2) : empty)))) (false) @@ -276,37 +287,36 @@ all? [land? . (map 0)] # returns true if element is part of a list based on eq predicate in? [[any? (\1 0)]] -:test (in? eq? (+3) ((+1) : ((+2) : ((+3) : empty)))) (true) -:test (in? eq? (+0) ((+1) : ((+2) : ((+3) : empty)))) (false) +:test (in? (=?) (+3) ((+1) : ((+2) : ((+3) : empty)))) (true) +:test (in? (=?) (+0) ((+1) : ((+2) : ((+3) : empty)))) (false) # returns true if all elements of one list are equal to corresponding elements of other list -# TODO: Better name -leq? [[[land? (zip-with 2 1 0)]]] +eq? &&( ... zip-with -:test (leq? eq? ((+1) : ((+2) : empty)) ((+1) : ((+2) : empty))) (true) -:test (leq? eq? ((+1) : ((+2) : empty)) ((+2) : ((+2) : empty))) (false) -:test (leq? eq? empty empty) (true) +:test (eq? (=?) ((+1) : ((+2) : empty)) ((+1) : ((+2) : empty))) (true) +:test (eq? (=?) ((+1) : ((+2) : empty)) ((+2) : ((+2) : empty))) (false) +:test (eq? (=?) empty empty) (true) # removes first element that match an eq predicate -remove Z [[[[case-some]]]] - case-some <>?0 case-end case-remove +remove Z [[[[rec]]]] + rec <>?0 case-end case-remove case-remove (2 ^0 1) ~0 (^0 : (3 2 1 ~0)) case-end empty -:test (remove eq? (+2) ((+1) : ((+2) : ((+3) : ((+2) : empty))))) ((+1) : ((+3) : ((+2) : empty))) +:test (remove (=?) (+2) ((+1) : ((+2) : ((+3) : ((+2) : empty))))) ((+1) : ((+3) : ((+2) : empty))) # removes duplicates from list based on eq predicate (keeps first occurrence) -nub Z [[[case-some]]] - case-some <>?0 case-end case-nub +nub Z [[[rec]]] + rec <>?0 case-end case-nub case-nub ^0 : (2 1 (~0 <#> [!(2 0 ^1)])) case-end empty -:test (nub eq? ((+1) : ((+2) : ((+3) : empty)))) (((+1) : ((+2) : ((+3) : empty)))) -:test (nub eq? ((+1) : ((+2) : ((+1) : empty)))) (((+1) : ((+2) : empty))) +:test (nub (=?) ((+1) : ((+2) : ((+3) : empty)))) (((+1) : ((+2) : ((+3) : empty)))) +:test (nub (=?) ((+1) : ((+2) : ((+1) : empty)))) (((+1) : ((+2) : empty))) # returns a list with infinite-times a element -repeat Z [[case-some]] - case-some 0 : (1 0) +repeat Z [[rec]] + rec 0 : (1 0) :test (take (+3) (repeat (+4))) ((+4) : ((+4) : ((+4) : empty))) @@ -316,14 +326,14 @@ replicate [[take 1 (repeat 0)]] :test (replicate (+3) (+4)) ((+4) : ((+4) : ((+4) : empty))) # returns an infinite list repeating a finite list -cycle Z [[case-some]] - case-some 0 ++ (1 0) +cycle Z [[rec]] + rec 0 ++ (1 0) :test (take (+6) (cycle "ab")) ("ababab") # returns a list with infinite-times previous (or start) value applied to a function -iterate Z [[[case-some]]] - case-some 0 : (2 1 (1 0)) +iterate Z [[[rec]]] + rec 0 : (2 1 (1 0)) :test (take (+5) (iterate inc (+0))) (((+0) : ((+1) : ((+2) : ((+3) : ((+4) : empty)))))) :test (take (+2) (iterate dec (+5))) (((+5) : ((+4) : empty))) diff --git a/std/Number.bruijn b/std/Number.bruijn index c7cce1b..376f8f0 100644 --- a/std/Number.bruijn +++ b/std/Number.bruijn @@ -10,19 +10,19 @@ # negative trit indicating coeffecient of (-1) t< [[[2]]] -# returns whether a trit is negative +# returns true if a trit is negative t<? [0 true false false] # positive trit indicating coeffecient of (+1) t> [[[1]]] -# returns whether a trit is positive +# returns true if a trit is positive t>? [0 false true false] # zero trit indicating coeffecient of 0 t= [[[0]]] -# returns whether a trit is zero +# returns true if a trit is zero t=? [0 false false true] :test (t<? t<) (true) @@ -127,7 +127,7 @@ mst [fix (last (list! %0))] :test (mst (+1)) (t>) :test (mst (+42)) (t>) -# returns whether balanced ternary number is negative +# returns true if balanced ternary number is negative negative? [t<? (mst 0)] <?( negative? @@ -137,7 +137,7 @@ negative? [t<? (mst 0)] :test (<?(+1)) (false) :test (<?(+42)) (false) -# returns whether balanced ternary number is positive +# returns true if balanced ternary number is positive positive? [t>? (mst 0)] >?( positive? @@ -147,7 +147,7 @@ positive? [t>? (mst 0)] :test (>?(+1)) (true) :test (>?(+42)) (true) -# checks whether balanced ternary number is zero +# checks true if balanced ternary number is zero zero? [0 true [false] [false] I] =?( zero? @@ -287,7 +287,7 @@ ssub strip .. sub :test (((+1) - (+2)) =? (-1)) (true) :test (((+42) - (+1)) =? (+41)) (true) -# returns whether number is greater than other number +# returns true if number is greater than other number # larger numbers should be second argument (performance) gre? [[>?(1 - 0)]] @@ -297,7 +297,7 @@ gre? [[>?(1 - 0)]] :test ((+2) >? (+2)) (false) :test ((+3) >? (+2)) (true) -# returns whether number is less than other number +# returns true if number is less than other number # smaller numbers should be second argument (performance) les? \gre? @@ -307,7 +307,7 @@ les? \gre? :test ((+2) <? (+2)) (false) :test ((+3) <? (+2)) (false) -# returns whether number is less than or equal to other number +# returns true if number is less than or equal to other number # smaller numbers should be second argument (performance) leq? [[!(1 >? 0)]] @@ -317,7 +317,7 @@ leq? [[!(1 >? 0)]] :test ((+2) <=? (+2)) (true) :test ((+3) <=? (+2)) (false) -# returns whether number is greater than or equal to other number +# returns true if number is greater than or equal to other number # smaller numbers should be second argument (performance) geq? \leq? diff --git a/std/Pair.bruijn b/std/Pair.bruijn index 46302cc..b21d193 100644 --- a/std/Pair.bruijn +++ b/std/Pair.bruijn @@ -10,17 +10,21 @@ pair [[[0 2 1]]] # extracts first expression from pair fst [0 K] +^( fst + # test fst with example pair of [[0]] and [[1]] -:test (fst ([[0]] : [[1]])) ([[0]]) +:test (^([[0]] : [[1]])) ([[0]]) # extracts second expression from pair snd [0 KI] +~( snd + # test snd with example pair of [[0]] and [[1]] -:test (snd ([[0]] : [[1]])) ([[1]]) +:test (~([[0]] : [[1]])) ([[1]]) # applies both elements of a pair to a function -uncurry [[1 (fst 0) (snd 0)]] +uncurry [[1 ^0 ~0]] # test uncurry with example pair of [[0]] and [[1]] and some combinator :test (uncurry W ([[0]] : [[1]])) ([[1]]) @@ -32,7 +36,7 @@ curry [[[2 (1 : 0)]]] :test (curry fst [[0]] [[1]]) ([[0]]) # swaps the values of a pair -swap [(snd 0) : (fst 0)] +swap [~0 : ^0] # test swap with example pair of [[0]] and [[1]] :test (swap ([[0]] : [[1]])) ([[1]] : [[0]]) diff --git a/std/String.bruijn b/std/String.bruijn new file mode 100644 index 0000000..4c872a8 --- /dev/null +++ b/std/String.bruijn @@ -0,0 +1,29 @@ +# MIT License, Copyright (c) 2022 Marvin Borner + +:import std/Byte B + +:input std/List + +# returns true if two strings are the same +eq? eq? B.eq? + +(=?) eq? + +:test ("ab" =? "ab") (true) +:test ("ab" =? "aa") (false) + +# splits string by newline character +lines Z [[rec]] + rec <>?(~broken) (^broken : empty) (^broken : (1 ~(~broken))) + broken break (B.eq? '\n') 0 + +:test (lines "ab\ncd") ("ab" : ("cd" : empty)) + +# :test (lines "ab\ncd\n") ("ab" : ("cd" : empty)) + +# concats list of strings with newline character +unlines concat-map (\(;) '\n') + +:test (unlines ("ab" : ("cd" : empty))) ("ab\ncd\n") + +main lines "ab\ncd" |