├── Debug.hs ├── FileQuoter.hs ├── DecompressString.hs ├── README.md ├── PrattParser.hs ├── IntSeq.hs ├── compressString.hs ├── Expr.hs ├── Codegen.hs ├── InputParser.hs ├── Codepage.hs ├── Husk.hs ├── Parser.hs ├── Infer.hs ├── Builtins.hs └── Defs.hs /Debug.hs: -------------------------------------------------------------------------------- 1 | module Debug where 2 | 3 | import Debug.Trace 4 | 5 | -- Debug level (0/1/2) 6 | debug = 0 7 | 8 | -- Conditional debug functions 9 | trace' :: Int -> String -> b -> b 10 | trace' level = if debug >= level then trace else flip const 11 | 12 | traceShow' :: (Show a) => Int -> a -> b -> b 13 | traceShow' level = if debug >= level then traceShow else flip const 14 | -------------------------------------------------------------------------------- /FileQuoter.hs: -------------------------------------------------------------------------------- 1 | module FileQuoter where 2 | 3 | import Language.Haskell.TH 4 | import Language.Haskell.TH.Quote 5 | 6 | -- Quasi-quoter for adding files as string constants 7 | -- Taken from https://stackoverflow.com/a/12717160/7588488 8 | litFile :: QuasiQuoter 9 | litFile = quoteFile $ QuasiQuoter {quoteExp = return . LitE . StringL, 10 | quotePat = undefined, 11 | quoteType = undefined, 12 | quoteDec = undefined} 13 | -------------------------------------------------------------------------------- /DecompressString.hs: -------------------------------------------------------------------------------- 1 | module DecompressString where 2 | 3 | import qualified Data.Map.Lazy as Map 4 | import System.IO.Unsafe (unsafePerformIO) 5 | import System.Environment (getExecutablePath) 6 | import System.FilePath (replaceFileName) 7 | 8 | decompressString :: String -> String 9 | decompressString s = go "" s where 10 | go prev (x:xs) | Just word <- Map.lookup (prev++[x]) dictionary = word ++ go "" xs 11 | | otherwise = go (prev++[x]) xs 12 | go _ [] = [] 13 | 14 | 15 | dictionary :: Map.Map String String 16 | dictionary = Map.fromDistinctAscList $ map splitTabs $ lines dict where 17 | splitTabs s | (first,tab:second) <- span (/='\t') s = (first,second) 18 | dict = unsafePerformIO $ getDict 19 | getDict = do 20 | path <- getExecutablePath 21 | readFile $ replaceFileName path "revdictionary.tsv" 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Husk 2 | 3 | Husk is a functional [golfing language](https://en.wikipedia.org/wiki/Code_golf), inspired by (and implemented in) [Haskell](https://haskell.org). 4 | Documentation can be found on the [Wiki](https://github.com/barbuz/Husk/wiki). 5 | 6 | ## Language concepts 7 | 8 | Many of the fundaments of this language are derived from Haskell, so if you are familiar with Haskell it will be easier for you to learn Husk. The main difference is given by a type inferencing step done at compilation time which can guess the desired function among different functions with the same name, basing on how their types unify with the types of other functions and the input. In practice, this means that most functions in Husk are overloaded to do different things based on the type of their arguments. 9 | 10 | ## Running Husk 11 | 12 | The Husk interpreter here provided requires a Haskell compiler. Download all the source files, compile `Husk.hs`, and you're set. 13 | 14 | An Husk program may be launched with the command `Husk`, passing as first argument the source of the program, and as following arguments the inputs to the program. When run, Husk will infer the possible types of the program and the inputs, unify them, and then produce an Haskell program with fixed typing which is executed right away. 15 | Husk reads Unicode source with the flag `-u`, byte-encoded source with the flag `-b`, and verbose ASCII source with the flag `-v`. 16 | For more information on using the interpreter, please check the Wiki. 17 | -------------------------------------------------------------------------------- /PrattParser.hs: -------------------------------------------------------------------------------- 1 | -- Simplified Pratt parser for expressions, adapted from http://stackoverflow.com/a/33534426 2 | 3 | module PrattParser where 4 | 5 | import Text.Parsec (Parsec, choice, (<|>)) 6 | import Data.List (tails) 7 | import Control.Applicative (pure, (<*>)) 8 | 9 | data Operator u t = Postfix (Parsec String u (t -> t)) 10 | | InfixL (Parsec String u (t -> t -> t)) -- Left associative 11 | | InfixR (Parsec String u (t -> t -> t)) -- Right associative 12 | 13 | -- Make a Pratt parser from a precedence table and a term parser 14 | -- Precedence table is given from highest to lowest precedence 15 | mkPrattParser :: [[Operator u t]] -> Parsec String u t -> Parsec String u t 16 | mkPrattParser precTable parseTerm = parseExpr precs 17 | where precs = reverse precTable -- We go from lowest to highest precedence 18 | parseExpr operators = do 19 | term <- parseTerm 20 | parseOper operators term 21 | parseOper operators lhs = choice stepParsers <|> return lhs -- Choose an operator; if fails, return lhs 22 | where stepParsers = do 23 | newPrecs@(precLev : higherPrecs) <- tails operators -- Choose a precedence level and all higher levels 24 | operator <- precLev -- Choose an operator from the level 25 | stepParser <- case operator of -- Make a "next step" parser 26 | Postfix parseOp -> return $ parseOp <*> pure lhs -- For postfix, just grab that 27 | InfixL parseOp -> return $ parseOp <*> pure lhs <*> parseExpr higherPrecs -- For left infix, grab everything with higher precedence 28 | InfixR parseOp -> return $ parseOp <*> pure lhs <*> parseExpr newPrecs -- For right infix, grab everything with same or higher precedence 29 | return $ stepParser >>= parseOper operators -- Parse with "next step", then with all operators 30 | -------------------------------------------------------------------------------- /IntSeq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts, BangPatterns #-} 2 | 3 | module IntSeq where 4 | -- Built-in integer sequences 5 | 6 | import Data.List 7 | import Defs 8 | 9 | func_intseq :: Char -> [TNum] 10 | 11 | --Alternate signs 12 | func_intseq '±' = concat $ transpose [[1..],[-1,-2..]] 13 | 14 | --All integers 15 | func_intseq 'Z' = 0 : func_intseq '±' 16 | 17 | --Yes/no sequence 18 | func_intseq '¬' = cycle [1,0] 19 | 20 | --Negatives 21 | func_intseq '-' = [-1,-2..] 22 | 23 | --Even 24 | func_intseq '0' = [2,4..] 25 | 26 | --Odd 27 | func_intseq '1' = [1,3..] 28 | 29 | --Powers of 2 30 | func_intseq '2' = map (2^) [1..] 31 | 32 | --Powers of 3 33 | func_intseq '3' = map (3^) [1..] 34 | 35 | --Powers of 5 36 | func_intseq '5' = map (5^) [1..] 37 | 38 | --Powers of 7 39 | func_intseq '7' = map (7^) [1..] 40 | 41 | --Fibonacci 42 | func_intseq 'f' = fibs 43 | where 44 | fibs = 1 : 1 : zipWith (+) fibs (tail fibs) 45 | 46 | --Primes (defined in Defs.hs) 47 | func_intseq 'p' = primes_list 48 | 49 | --Ruler sequence (exponent of highest power of 2 dividing n), OEIS A007814 50 | func_intseq 'r' = 0:concatMap(\x->[x+1,0])(func_intseq 'r') 51 | 52 | --Money values (1,2,5 and their multiples by 10) 53 | func_intseq '₅' = concat $ iterate (map (*10)) [1,2,5] 54 | 55 | --Digits of Pi. Algorithm taken from: Gibbons, Jeremy. "Unbounded spigot algorithms for the digits of pi." The American Mathematical Monthly 113.4 (2006): 318-328. 56 | func_intseq 'π' = g(1,180,60,2) where 57 | g(q,r,t,i) = let (u,y)=(3*(3*i+1)*(3*i+2),div(q*(27*i-12)+5*r)(5*t)) 58 | in y : g(10*q*i*(2*i-1),10*u*(q*(5*i-2)+r-y*t),t*u,i+1) 59 | 60 | --Powers of 10 61 | func_intseq '⁰' = map (10^) [1..] 62 | 63 | --Euro coins and notes values 64 | func_intseq '€' = [0.01,0.02,0.05,0.1,0.2,0.5,1,2,5,10,20,50,100,200,500] 65 | 66 | --Squares 67 | func_intseq '□' = map (^2) [1..] 68 | 69 | --Palindromic numbers in base 10 70 | func_intseq '↔' = filter (((==) =<< reverse) . func_base10) [1..] 71 | 72 | --Palindromic numbers in base 2 73 | func_intseq '↕' = filter (((==) =<< reverse) . func_base2) [1..] 74 | 75 | --Powers of -1 76 | func_intseq '_' = cycle [-1,1] 77 | 78 | --Inverses of positive integers 79 | func_intseq '\\' = map recip [1..] 80 | 81 | --Powers of 1/2 82 | func_intseq '½' = map (recip . (2^)) [1..] 83 | 84 | 85 | func_intseq c = error $ "Unimplemented integer sequence for character '"++c:"'" 86 | -------------------------------------------------------------------------------- /compressString.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Map.Strict as Map 2 | import Data.List (inits) 3 | import System.Environment (getArgs) 4 | import System.Console.GetOpt 5 | import System.IO (hPutStrLn,stderr) 6 | --import Debug.Trace (trace) 7 | 8 | type Node = (Int,[String]) 9 | 10 | consoleOpts :: [OptDescr Bool] 11 | consoleOpts = [Option ['1'] [] (NoArg $ True) "Return only a single result"] 12 | 13 | main = do args <- getArgs 14 | let parsedArgs = getOpt Permute consoleOpts args 15 | 16 | case parsedArgs of 17 | (opt,plainText:[],[]) -> do 18 | putStrLn $ "Original length: "++show (length plainText)++" bytes." 19 | dictionary <- readFile "dictionary.tsv" 20 | let results = compressString (elem True opt) plainText $ buildDict dictionary 21 | putStrLn $ "Compressed length: "++show (length $ head results)++" bytes." 22 | putStr $ unlines $ map quote results 23 | (_,_,errors) -> hPutStrLn stderr $ unlines errors ++ usageInfo "Usage: compressString [OPT] string" consoleOpts 24 | where 25 | buildDict text = Map.fromDistinctAscList $ map splitTab $ lines text 26 | splitTab s | (first,tab:second) <- span (/='\t') s = (first,second) 27 | quote s = '¨':s++"¨" 28 | 29 | replaceNewlines :: Char -> Char 30 | replaceNewlines '\n' = '¶' 31 | replaceNewlines c = c 32 | 33 | compressString :: Bool -> String -> Map.Map String String -> [String] 34 | compressString opt s dictionary = go [(0, [""])] (map replaceNewlines s) where 35 | 36 | go :: [Node] -> String -> [String] 37 | go ((_,encoded):_) [] = encoded 38 | go (node:nodes) plain = go (chooseBest nodes (extend node (encodeStart plain))) $ tail plain 39 | 40 | encodeStart :: String -> [Node] 41 | encodeStart s = map buildNode $ take maxDictWordLen $ tail $ inits s where 42 | maxDictWordLen = 10 43 | buildNode ngram | Just code <- Map.lookup ngram dictionary = (length code,[code]) 44 | | otherwise = (0,[]) 45 | 46 | extend :: Node -> [Node] -> [Node] 47 | extend node nodes = map (addNode node) nodes where 48 | addNode _ (0,[]) = (0,[]) 49 | addNode (l1,previous) (l2,[current]) = (l1+l2,map (++current) previous) 50 | 51 | chooseBest :: [Node] -> [Node] -> [Node] 52 | chooseBest as [] = as 53 | chooseBest [] bs = bs 54 | chooseBest (a:as) (b@(_,[]):bs) = a:chooseBest as bs 55 | chooseBest (a@(_,[]):as) (b:bs) = b:chooseBest as bs 56 | chooseBest (a@(l1,w1):as) (b@(l2,w2):bs) | l1 < l2 = a:chooseBest as bs 57 | | l1 ==l2 && not opt = (l1,w1++w2):chooseBest as bs 58 | | otherwise = b:chooseBest as bs 59 | -------------------------------------------------------------------------------- /Expr.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Expressions and types 3 | 4 | {-# LANGUAGE DeriveFunctor #-} 5 | 6 | module Expr where 7 | 8 | import Debug 9 | 10 | -- Labels for type and expression variables 11 | type TLabel = String 12 | type ELabel = String 13 | 14 | -- Expression containing generalized literals 15 | data Exp lit = EVar ELabel 16 | | ELine Int 17 | | ELit lit 18 | | EApp (Exp lit) (Exp lit) 19 | | EOp (Exp lit) (Exp lit) (Exp lit) 20 | | EAbs ELabel (Exp lit) 21 | | ELet ELabel (Exp lit) (Exp lit) 22 | deriving (Eq, Ord, Functor) 23 | 24 | instance (Show lit) => Show (Exp lit) where 25 | show (EVar name) = name 26 | show (ELine n) = "line" ++ show n 27 | show (ELit lit) = show lit 28 | show (EApp a b) | show a == "app" = show b 29 | | show a `elem` words "com4 com3 com2 com" = "(" ++ show b ++ ")`" ++ show a ++ "`" 30 | | otherwise = show a ++ "(" ++ show b ++ ")" 31 | show (EOp a b c) = show $ EApp (EApp a b) c 32 | show (EAbs name exp) = "(\\" ++ name ++ "." ++ show exp ++ ")" 33 | show (ELet name exp body) = "let " ++ name ++ "=(" ++ show exp ++ ") in " ++ show body 34 | 35 | -- Literal in expression; t is the type 36 | data Lit t = Value String t 37 | | Builtin String t 38 | | Vec t 39 | | Vec2 Bool t -- True means zip', False means zip 40 | deriving (Eq, Ord) 41 | 42 | instance Show (Lit a) where 43 | show (Value name _) = name 44 | show (Builtin name _) = name 45 | show (Vec _) = "vec" 46 | show (Vec2 False _) = "vec2" 47 | show (Vec2 True _) = "vec2'" 48 | 49 | -- Type of expression with unbound variables 50 | data Type = TVar TLabel 51 | | TConc Conc 52 | | TList Type 53 | | TPair Type Type 54 | | TFun Type Type 55 | deriving (Eq, Ord) 56 | 57 | -- Convenience alias for TFun 58 | infixr 9 ~> 59 | (~>) = TFun 60 | 61 | instance Show Type where 62 | show (TVar name) = name 63 | show (TConc c) = show c 64 | show (TList t) = "[" ++ show t ++ "]" 65 | show (TPair a b) = "(" ++ show a ++ "," ++ show b ++ ")" 66 | show (TFun a b) = "(" ++ show a ++ "->" ++ show b ++ ")" 67 | 68 | -- Concrete type 69 | data Conc = TNum 70 | | TChar 71 | | TNil 72 | deriving (Eq, Ord, Show) 73 | 74 | -- Type with typeclass constraints 75 | data CType = CType [TClass] Type 76 | deriving (Eq, Ord) 77 | 78 | instance Show CType where 79 | show (CType cons typ) = show cons ++ "=>" ++ show typ 80 | 81 | -- Possible typeclass constraints 82 | data TClass = Vect Type Type Type Type 83 | | Vect2 Type Type Type Type Type Type 84 | | Concrete Type 85 | deriving (Eq, Ord, Show) 86 | 87 | -- Type of expression with universally quantified variables 88 | data Scheme = Scheme [TLabel] CType 89 | deriving (Eq, Ord) 90 | 91 | instance Show Scheme where 92 | show (Scheme vs t) = concatMap (\name -> "forall " ++ name ++ ".") vs ++ show t 93 | -------------------------------------------------------------------------------- /Codegen.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Code generation 3 | 4 | module Codegen where 5 | 6 | import Expr 7 | import Infer 8 | 9 | import Data.List (intercalate) 10 | import Data.Maybe (catMaybes) 11 | import qualified Data.Set as S (null) 12 | 13 | -- Convert type to Haskell code 14 | typeToHaskell :: Type -> String 15 | typeToHaskell (TVar name) = name 16 | typeToHaskell (TConc TNum) = "TNum" 17 | typeToHaskell (TConc TChar) = "Char" 18 | typeToHaskell (TConc TNil) = "()" 19 | typeToHaskell (TList t) = "[" ++ typeToHaskell t ++ "]" 20 | typeToHaskell (TPair s t) = "(" ++ typeToHaskell s ++ "," ++ typeToHaskell t ++ ")" 21 | typeToHaskell (TFun s t) = "(" ++ typeToHaskell s ++ " -> " ++ typeToHaskell t ++ ")" 22 | 23 | -- Convert typeclass constraint to Haskell code 24 | consToHaskell :: TClass -> Maybe String 25 | consToHaskell con | S.null $ freeVars con = Nothing 26 | consToHaskell (Concrete t) = Just $ "Concrete " ++ typeToHaskell t 27 | consToHaskell (Vect _ _ _ _) = Nothing 28 | consToHaskell (Vect2 _ _ _ _ _ _) = Nothing 29 | 30 | -- Convert classed type to Haskell code 31 | cTypeToHaskell :: CType -> String 32 | cTypeToHaskell (CType cons typ) 33 | | cons' <- catMaybes $ map consToHaskell cons = 34 | if null cons' 35 | then typeToHaskell typ 36 | else "(" ++ intercalate "," cons' ++ ") => " ++ typeToHaskell typ 37 | 38 | -- Convert expression to Haskell code 39 | expToHaskell :: Exp (Lit CType) -> String 40 | expToHaskell (EVar name) = name 41 | expToHaskell (ELine n) = "line" ++ show n 42 | expToHaskell (ELit (Value name typ)) = "(" ++ name ++ "::" ++ cTypeToHaskell typ ++ ")" 43 | expToHaskell (ELit (Builtin name typ)) = "(func_" ++ name ++ "::" ++ cTypeToHaskell typ ++ ")" 44 | expToHaskell (ELit (Vec typ)) = vecToHaskell typ 45 | expToHaskell (ELit (Vec2 kind typ)) = vec2ToHaskell kind typ 46 | expToHaskell (EApp a b) = "(" ++ expToHaskell a ++ ")(" ++ expToHaskell b ++ ")" 47 | expToHaskell (EOp _ _ _) = error "expToHaskell not defined for EOp" 48 | expToHaskell (EAbs name exp) = "(\\ " ++ name ++ " -> " ++ expToHaskell exp ++ ")" 49 | expToHaskell (ELet name exp body) = "(let " ++ name ++ " = " ++ expToHaskell exp ++ " in " ++ expToHaskell body ++ ")" 50 | 51 | -- Convert type of Vec to Haskell expression (nested maps) 52 | -- Type will always be of the form (a -> b) -> (x -> y) 53 | vecToHaskell typ@(CType _ (TFun (TFun a b) (TFun x y))) = "(id" ++ concat (replicate (nesting x) ".fmap") ++ "::" ++ cTypeToHaskell typ ++ ")" 54 | where nesting t | t == a = 0 55 | | TList t' <- t = 1 + nesting t' 56 | | otherwise = error "Illegal type for Vec" 57 | 58 | -- Convert type of Vec2 to Haskell expression (nested zips) 59 | -- Type will always be of the form (a -> b -> c) -> (x -> y -> z) 60 | vec2ToHaskell kind typ@(CType _ (TFun (TFun a (TFun b c)) (TFun x (TFun y z)))) = 61 | "(" ++ nesting x y ++ "::" ++ cTypeToHaskell typ ++ ")" 62 | where nesting t1 t2 | t1 == a, t2 == b = "id" 63 | | TList t1' <- t1, t2 == b = nesting t1' t2 ++ ".func_lmap" 64 | | t1 == a, TList t2' <- t2 = nesting t1 t2' ++ ".func_rmap" 65 | | TList t1' <- t1, TList t2' <- t2 = nesting t1' t2' ++ (if kind then ".func_zip'" else ".func_zip") 66 | | otherwise = error $ "Illegal type for Vec2: " ++ show typ 67 | -------------------------------------------------------------------------------- /InputParser.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Parser for recognizing types of inputs 3 | 4 | module InputParser where 5 | 6 | import Expr 7 | import Infer 8 | import Debug 9 | import Text.Parsec 10 | import Data.List (intercalate,nub) 11 | import Control.Monad (foldM) 12 | 13 | type InputParser = Parsec String () (Maybe (String, Type)) 14 | 15 | unifyInputs :: Type -> Type -> Maybe Type 16 | unifyInputs t1 t2 | trace' 2 ("unifying input types " ++ show t1 ++ " and " ++ show t2) False = undefined 17 | unifyInputs (TPair t1 t2) (TPair s1 s2) = do 18 | r1 <- unifyInputs t1 s1 19 | r2 <- unifyInputs t2 s2 20 | return $ TPair r1 r2 21 | unifyInputs (TList t1) (TList t2) = unifyInputs t1 t2 >>= return . TList 22 | unifyInputs t1@(TConc _) t2 | t1 == t2 = Just t1 23 | unifyInputs (TVar _) t = Just t 24 | unifyInputs t (TVar _) = Just t 25 | unifyInputs _ _ = Nothing 26 | 27 | number :: InputParser 28 | number = do 29 | minus <- optionMaybe $ char '-' 30 | prefix <- many1 digit 31 | suffix <- optionMaybe $ do 32 | sep <- oneOf "./" 33 | rest <- many1 digit 34 | return (sep:rest) 35 | let number = case (minus, suffix) of 36 | (Just _, Just suffix) -> '-' : prefix ++ suffix 37 | (Just _, Nothing) -> '-' : prefix 38 | (Nothing, Just suffix) -> prefix ++ suffix 39 | (Nothing, Nothing) -> prefix 40 | return $ Just (number, TConc TNum) 41 | 42 | character :: InputParser 43 | character = do 44 | char '\'' 45 | c <- noneOf "\\'" <|> (fmap (\c -> if c == 'n' then '\n' else c) $ char '\\' >> oneOf "\\'n") 46 | char '\'' 47 | return $ Just (show c, TConc TChar) 48 | 49 | plainStr :: InputParser 50 | plainStr = do 51 | chars <- many $ noneOf "\\\"" <|> (fmap (\c -> if c == 'n' then '\n' else c) $ char '\\' >> oneOf "\\\"n") 52 | return $ Just (show chars, TList (TConc TChar)) 53 | 54 | str :: InputParser 55 | str = do 56 | char '"' 57 | contents <- plainStr 58 | char '"' 59 | return contents 60 | 61 | list :: InputParser 62 | list = do 63 | char '[' 64 | maybeElems <- sepBy inputVal (char ',') 65 | char ']' 66 | return $ do 67 | elems <- sequence maybeElems 68 | let outStr = "[" ++ intercalate "," (map fst elems) ++ "]" 69 | outType <- foldM unifyInputs (TVar "x") $ map snd elems 70 | return (outStr, TList outType) 71 | 72 | pair :: InputParser 73 | pair = do 74 | char '(' 75 | elem1 <- inputVal 76 | char ',' 77 | elem2 <- inputVal 78 | char ')' 79 | return $ do 80 | (str1, typ1) <- elem1 81 | (str2, typ2) <- elem2 82 | return ("(" ++ str1 ++ "," ++ str2 ++ ")", TPair typ1 typ2) 83 | 84 | inputVal :: InputParser 85 | inputVal = try number <|> try character <|> try list <|> try pair <|> str 86 | 87 | input :: InputParser 88 | input = do 89 | maybeInputVal <- inputVal 90 | maybeTyp <- optionMaybe $ char ':' >> inputType 91 | eof 92 | return $ case (maybeInputVal, maybeTyp) of 93 | (Nothing, _) -> Nothing 94 | (val@(Just _), Nothing) -> val 95 | (val, Just typ) -> do 96 | (str, infTyp) <- val 97 | newTyp <- unifyInputs infTyp typ 98 | return $ (str, newTyp) 99 | 100 | inputType :: Parsec String () Type 101 | inputType = numT <|> charT <|> varT <|> listT <|> pairT 102 | where numT = char 'N' >> return (TConc TNum) 103 | charT = char 'C' >> return (TConc TChar) 104 | varT = lower >>= \c-> return (TVar [c]) 105 | listT = char 'L' >> fmap TList inputType 106 | pairT = char 'P' >> do 107 | first <- inputType 108 | second <- inputType 109 | return $ TPair first second 110 | 111 | parseInput :: Int -> String -> Either String (Maybe (String, Type)) 112 | parseInput inputIndex str = 113 | case parse (try input <|> plainStr) ("input" ++ show inputIndex) str of 114 | Left err -> Left $ show err 115 | Right val -> Right $ trace' 1 ("input " ++ show inputIndex ++ ", " ++ str ++ ", is " ++ show val) val 116 | -------------------------------------------------------------------------------- /Codepage.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Implementation of the Husk code page 3 | 4 | module Codepage where 5 | 6 | import Data.Word 7 | import Data.List 8 | 9 | -- The Husk code page: 256 characters, each representing one byte 10 | codepage :: String 11 | codepage = "¤½↕↑↓↔←→∟¦\n¡¿‼…‰†‡√≤≥±∂∫∞≈≠≡⌐¬÷×" ++ 12 | " !\"#$%&'()*+,-./0123456789:;<=>?" ++ 13 | "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_" ++ 14 | "`abcdefghijklmnopqrstuvwxyz{|}~·" ++ 15 | "₀₁₂₃₄₅₆₇₈₉⌈⌉⌊⌋ΓΔΘΛΞΠΣΦΨΩαβγδεζηθ" ++ 16 | "λμξπρςστφχψω⁰¹²³⁴⁵⁶⁷⁸⁹¢£€¥ƒ´▲▼►◄" ++ 17 | "§ȦḂĊḊĖḞĠḢİĿṀṄȮṖṘṠṪẆẊẎŻȧḃċḋėḟġḣıȷ" ++ 18 | "ŀṁṅȯṗṙṡṫẇẋẏż¨ÄËÏÖÜŸØäëïöüÿø◊□¶«»" 19 | 20 | 21 | -- A short ASCII alias for each non-ASCII char in the code page 22 | aliases :: [(Char, String)] 23 | aliases = [('¤', "cur"), ('½', "hlf"), ('↕', "ud"), ('↑', "up"), ('↓', "dow"), ('↔', "lr"), ('←', "lft"), ('→', "rgt"), 24 | ('∟', "ang"), ('¦', "bar"), ('¡', "exc"), ('¿', "que"), ('‼', "dex"), ('…', "ell"), ('‰', "ppm"), 25 | ('†', "dag"), ('‡', "ddg"), ('√', "srd"), ('≤', "leq"), ('≥', "geq"), ('±', "pm"), ('∂', "ptl"), ('∫', "int"), 26 | ('∞', "inf"), ('≈', "apx"), ('≠', "neq"), ('≡', "cng"), ('⌐', "gen"), ('¬', "neg"), ('÷', "div"), ('×', "eks"), 27 | ('·', "blt"), 28 | ('₀', "nul"), ('₁', "one"), ('₂', "two"), ('₃', "tre"), ('₄', "for"), ('₅', "fiv"), ('₆', "six"), ('₇', "sev"), 29 | ('₈', "ate"), ('₉', "nin"), ('⌈', "lce"), ('⌉', "rce"), ('⌊', "lfl"), ('⌋', "rfl"), ('Γ', "Gam"), ('Δ', "Del"), 30 | ('Θ', "The"), ('Λ', "Lam"), ('Ξ', "Xi"), ('Π', "Pi"), ('Σ', "Sig"), ('Φ', "Phi"), ('Ψ', "Psi"), ('Ω', "Ohm"), 31 | ('α', "alp"), ('β', "bet"), ('γ', "gam"), ('δ', "del"), ('ε', "eps"), ('ζ', "zet"), ('η', "eta"), ('θ', "the"), 32 | ('λ', "lam"), ('μ', "mu"), ('ξ', "xi"), ('π', "pi"), ('ρ', "rho"), ('ς', "sig"), ('σ', "sjg"), ('τ', "tau"), 33 | ('φ', "phi"), ('χ', "chi"), ('ψ', "psi"), ('ω', "ohm"), ('⁰', "Nul"), ('¹', "One"), ('²', "Two"), ('³', "Tre"), 34 | ('⁴', "For"), ('⁵', "Fiv"), ('⁶', "Six"), ('⁷', "Sev"), ('⁸', "Ate"), ('⁹', "Nin"), ('¢', "cnt"), ('£', "gbp"), 35 | ('€', "eur"), ('¥', "yen"), ('ƒ', "fl"), ('´', "acu"), ('▲', "top"), ('▼', "bot"), ('►', "est"), ('◄', "wst"), 36 | ('§', "sec"), ('Ȧ', "dA"), ('Ḃ', "dB"), ('Ċ', "dC"), ('Ḋ', "dD"), ('Ė', "dE"), ('Ḟ', "dF"), ('Ġ', "dG"), 37 | ('Ḣ', "dH"), ('İ', "dI"), ('Ŀ', "dL"), ('Ṁ', "dM"), ('Ṅ', "dN"), ('Ȯ', "dO"), ('Ṗ', "dP"), ('Ṙ', "dR"), 38 | ('Ṡ', "dS"), ('Ṫ', "dT"), ('Ẇ', "dW"), ('Ẋ', "dX"), ('Ẏ', "dY"), ('Ż', "dZ"), ('ȧ', "da"), ('ḃ', "db"), 39 | ('ċ', "dc"), ('ḋ', "dd"), ('ė', "de"), ('ḟ', "df"), ('ġ', "dg"), ('ḣ', "dh"), ('ı', "di"), ('ȷ', "dj"), 40 | ('ŀ', "dl"), ('ṁ', "dm"), ('ṅ', "dn"), ('ȯ', "do"), ('ṗ', "dp"), ('ṙ', "dr"), ('ṡ', "ds"), ('ṫ', "dt"), 41 | ('ẇ', "dw"), ('ẋ', "dx"), ('ẏ', "dy"), ('ż', "dz"), ('¨', "die"), ('Ä', "DA"), ('Ë', "DE"), ('Ï', "DI"), 42 | ('Ö', "DO"), ('Ü', "DU"), ('Ÿ', "DY"), ('Ø', "sO"), ('ä', "Da"), ('ë', "De"), ('ï', "Di"), ('ö', "Do"), 43 | ('ü', "Du"), ('ÿ', "Dy"), ('ø', "so"), ('◊', "loz"), ('□', "squ"), ('¶', "pgf"), ('«', "ll"), ('»', "rr")] 44 | 45 | -- Convert a list of bytes into a string using the code page 46 | getCommands :: [Word8] -> String 47 | getCommands = map $ (codepage !!) . fromEnum 48 | 49 | -- Get the position of a character in the code page 50 | findByte :: Char -> Int 51 | findByte byte | Just ix <- elemIndex byte codepage = ix 52 | | otherwise = error "Bad byte" 53 | 54 | -- Convert a program to list of bytes 55 | getBytes :: String -> [Word8] 56 | getBytes = map $ toEnum . findByte 57 | 58 | -- Get the alias of a character 59 | getAlias :: Char -> String 60 | getAlias c | Just str <- lookup c aliases = '\\' : str ++ "\\" 61 | | c == '\\' = "\\\\" 62 | | otherwise = [c] 63 | 64 | -- Convert terse program to verbose program 65 | toAliases :: String -> String 66 | toAliases = concatMap getAlias 67 | 68 | -- Get the character of an alias 69 | fromAlias :: String -> Maybe Char 70 | fromAlias "" = Just '\\' 71 | fromAlias str = lookup str $ map (\(a,b) -> (b,a)) aliases 72 | 73 | -- Convert verbose program to terse program 74 | parseAliases :: String -> Either String String 75 | parseAliases ('\\':str) = do 76 | let (alias, rest) = break (== '\\') str 77 | char = case (rest, fromAlias alias) of 78 | ([], _) -> Left $ "Parse error (missing \\): " ++ alias 79 | (_ : rest, Just c) -> Right c 80 | (_, Nothing) -> Left $ "No character with alias " ++ alias 81 | 82 | (:) <$> char <*> parseAliases (drop 1 rest) 83 | parseAliases (char : str) = (char :) <$> parseAliases str 84 | parseAliases "" = Right "" 85 | -------------------------------------------------------------------------------- /Husk.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | -- Main program 4 | 5 | import Debug 6 | import Expr 7 | import Infer 8 | import Parser 9 | import InputParser 10 | import Codepage 11 | import Codegen 12 | import FileQuoter 13 | import System.Environment (getArgs) 14 | import System.Console.GetOpt 15 | import System.Process 16 | import System.IO 17 | import qualified Data.ByteString as B 18 | import Data.List (find, intercalate, nub) 19 | import Data.Set (toAscList) 20 | 21 | -- Wrapper for expression parser 22 | parseProg :: Bool -> String -> [Type] -> Either String [[(Int, CType, Exp (Lit CType))]] 23 | parseProg constrainRes prog types = inferType constrainRes (foldr typeConstr resType types) <$> parseExpr prog 24 | where typeConstr typ1 (Scheme vars (CType cons typ2)) = 25 | Scheme (nub $ vars ++ toAscList (freeVars typ1)) $ 26 | CType cons $ 27 | TFun typ1 typ2 28 | cons = if constrainRes then [Concrete $ TVar "x"] else [] 29 | resType = Scheme ["x"] $ CType cons $ TVar "x" 30 | 31 | -- Input format flags 32 | data Format = Bytes 33 | | Unicode 34 | | Verbose 35 | deriving (Eq, Show) 36 | 37 | -- Command line option flags 38 | data Flag = InferType 39 | | InferInputType 40 | | InFile 41 | | OutFile String 42 | | Format Format 43 | | Translate Format 44 | deriving (Eq, Show) 45 | 46 | isOutFile :: Flag -> Bool 47 | isOutFile (OutFile _) = True 48 | isOutFile _ = False 49 | 50 | isFormat :: Flag -> Bool 51 | isFormat (Format _) = True 52 | isFormat _ = False 53 | 54 | isTranslate :: Flag -> Bool 55 | isTranslate (Translate _) = True 56 | isTranslate _ = False 57 | 58 | -- Command line options 59 | consoleOpts :: [OptDescr Flag] 60 | consoleOpts = [Option ['b'] ["bytes"] (NoArg $ Format Bytes) "take input as bytes", 61 | Option ['u'] ["unicode"] (NoArg $ Format Unicode) "take input as Unicode characters", 62 | Option ['v'] ["verbose"] (NoArg $ Format Verbose) "take input as verbose ASCII", 63 | Option ['i'] ["infer"] (NoArg InferType) "only infer type(s) of given program", 64 | Option ['I'] ["infer2"] (NoArg InferInputType) "infer type(s) of given program, taking input type(s) into account", 65 | Option ['f'] ["file"] (NoArg InFile) "read program from file", 66 | Option ['o'] ["out"] (ReqArg OutFile "FILE") "produce Haskell file of given name", 67 | Option ['t'] ["translate"] (ReqArg (Translate . parseFormat) "FORMAT") "translate source to specified format (b/u/v)" 68 | ] 69 | where parseFormat "b" = Bytes 70 | parseFormat "u" = Unicode 71 | parseFormat "v" = Verbose 72 | parseFormat _ = error "Bad format specifier" 73 | 74 | -- Imports needed for transpiled file 75 | fileImports :: String 76 | fileImports = unlines $ map ("import "++) $ ["Defs", "IntSeq", "System.Environment (getArgs)"] 77 | 78 | -- Produce Haskell file from list of type-inferred lines 79 | produceFile :: [(Int, CType, Exp (Lit CType))] -> String 80 | produceFile exprs = 81 | fileImports ++ 82 | progLines ++ 83 | "main :: IO ()\n" ++ 84 | "main = do{[" ++ intercalate "," argList ++ "] <- getArgs; " ++ 85 | "let{res = line0 " ++ concatMap (\a -> "(read " ++ a ++ ")") argList ++ "}; " ++ 86 | "putStr (toString res)}" 87 | where progLines = concat [ label ++ " :: " ++ cTypeToHaskell typ ++ "\n" ++ 88 | label ++ " = " ++ expToHaskell expr ++ "\n" 89 | | (i, typ, expr) <- exprs, 90 | let label = "line" ++ show i] 91 | (_, CType _ mainTyp, _) = exprs !! 0 92 | argList = ["arg" ++ show i | i <- [1..numArgs mainTyp]] 93 | numArgs (TFun _ t) = 1 + numArgs t 94 | numArgs _ = 0 95 | 96 | main = do 97 | args <- getArgs 98 | let parsedArgs = getOpt RequireOrder consoleOpts args 99 | case parsedArgs of 100 | (opts, (progOrFile : progArgs), []) -> traceShow' 1 opts $ do 101 | errOrProg <- if InFile `elem` opts 102 | then case find isFormat opts of 103 | Just (Format Bytes) -> Right . getCommands . B.unpack <$> B.readFile progOrFile 104 | Just (Format f) -> do 105 | handle <- openFile progOrFile ReadMode 106 | hSetEncoding handle utf8 107 | contents <- hGetContents handle 108 | return $ case f of 109 | Verbose -> parseAliases contents 110 | _ -> Right contents 111 | _ -> return $ Left "Must supply input format" 112 | else return $ case find isFormat opts of 113 | Just (Format Bytes) -> Left "Byte format not supported for console input" 114 | Just (Format Verbose) -> parseAliases progOrFile 115 | Just (Format Unicode) -> Right progOrFile 116 | _ -> Left "Must supply input format" 117 | case errOrProg of 118 | Left err -> putStrLn err 119 | Right prog -> 120 | let progInputs :: Either String (Maybe [(String,Type)]) 121 | progInputs = fmap sequence $ sequence $ zipWith parseInput [1..] progArgs 122 | in case progInputs of 123 | Left err -> putStrLn err 124 | Right Nothing -> putStrLn "Could not infer valid type(s) for input(s)" 125 | Right (Just typedArgs) -> 126 | if any (`elem` opts) [InferType, InferInputType] 127 | then let constrainType = InferInputType `elem` opts 128 | inputs = if InferInputType `elem` opts then map snd typedArgs else [] 129 | in case parseProg constrainType prog inputs of 130 | Left err -> putStrLn err 131 | Right typings -> flip mapM_ typings $ 132 | \exprs -> do 133 | putStrLn "%%%%" 134 | flip mapM_ exprs $ 135 | \(i, typ, expr) -> do 136 | putStrLn $ "line" ++ show i ++ " = " ++ show expr ++ " :: " ++ show typ 137 | else case find isTranslate opts of 138 | Just (Translate Verbose) -> putStrLn $ toAliases prog 139 | Just (Translate Unicode) -> putStrLn prog 140 | Just (Translate Bytes) -> 141 | let bytes = B.pack $ getBytes prog 142 | in case find isOutFile opts of 143 | Just (OutFile filename) -> B.writeFile filename bytes 144 | _ -> B.putStr bytes 145 | _ -> do 146 | let outfile = case (find isOutFile opts, InFile `elem` opts) of 147 | (Just (OutFile s), _) -> s 148 | (Nothing, True) -> progOrFile ++ ".hs" 149 | (Nothing, False) -> ".out.hs" 150 | case parseProg True prog (map snd typedArgs) of 151 | Left err -> putStrLn err 152 | Right [] -> putStrLn "Could not infer valid type for program" 153 | Right (lineExprs : _) -> do writeFile outfile $ produceFile lineExprs 154 | (_, Just hout, _, _) <- createProcess (proc "runhaskell" (outfile : map fst typedArgs)){ std_out = CreatePipe } 155 | result <- hGetContents hout 156 | hSetBuffering stdout NoBuffering 157 | putStr result 158 | (_, _, errs) -> putStrLn $ concat errs ++ usageInfo "Usage: main [OPTION...] [FILE|EXPR] [INPUT...]" consoleOpts 159 | -------------------------------------------------------------------------------- /Parser.hs: -------------------------------------------------------------------------------- 1 | 2 | module Parser where 3 | 4 | import Debug 5 | import Expr 6 | import Builtins 7 | import PrattParser 8 | import DecompressString 9 | import Codepage 10 | import Text.Parsec 11 | import Text.Parsec.Char 12 | import Control.Monad (forM, foldM) 13 | import qualified Data.Map as Map 14 | import Data.List (elemIndex) 15 | import Data.Maybe (catMaybes) 16 | 17 | -- Parser state 18 | data PState = PState {varStack :: [(Maybe ELabel, Maybe ELabel)], 19 | varSupply :: Int, 20 | numLines :: Int, 21 | unmarked :: [Int]} 22 | 23 | -- Parser type 24 | type Parser = Parsec String PState 25 | 26 | -- Unwrapped parser, giving strings for errors 27 | parseExpr :: String -> Either String [Exp [Lit Scheme]] 28 | parseExpr str = case runParser multiline initState "" str of 29 | Left err -> Left $ show err 30 | Right val -> Right val 31 | where initState = PState [] 0 0 [] 32 | 33 | -- Generate a new expression variable 34 | genVar :: String -> Parser ELabel 35 | genVar s = do 36 | stat <- getState 37 | let var = s ++ show (varSupply stat) 38 | putState stat{varSupply = varSupply stat + 1} 39 | return $ trace' 2 ("created " ++ var) var 40 | 41 | -- Push a block, possibly with generated expression variables 42 | pushBlock :: (Bool, Bool) -> Parser () 43 | pushBlock (gen1, gen2) = do 44 | var1 <- if gen1 45 | then Just <$> genVar "x" 46 | else return Nothing 47 | var2 <- if gen2 48 | then Just <$> genVar "x" 49 | else return Nothing 50 | stat <- getState 51 | putState stat{varStack = trace' 2 ("pushed " ++ show var1 ++ ", " ++ show var2) $ (var1, var2) : varStack stat} 52 | 53 | -- Append a block, possibly with generated expression variables 54 | appendBlock :: (Bool, Bool) -> Parser (Maybe ELabel, Maybe ELabel) 55 | appendBlock (gen1, gen2) = do 56 | var1 <- if gen1 57 | then Just <$> genVar "y" 58 | else return Nothing 59 | var2 <- if gen2 60 | then Just <$> genVar "y" 61 | else return Nothing 62 | stat <- getState 63 | putState stat{varStack = varStack stat ++ [(var1, var2)]} 64 | return $ trace' 2 ("appended " ++ show var1 ++ ", " ++ show var2) (var1, var2) 65 | 66 | -- Create a variable at a specific stack index 67 | putVarAt :: Int -> Parser ELabel 68 | putVarAt ix = do 69 | newVar <- genVar "z" 70 | stat <- getState 71 | let (before, (var1, var2) : after) = splitAt (div ix 2) $ varStack stat 72 | putState $ if even ix 73 | then stat{varStack = before ++ (Just newVar, var2) : after} 74 | else stat{varStack = before ++ (var1, Just newVar) : after} 75 | return newVar 76 | 77 | -- Peek at a variable from the stack; extend stack if necessary 78 | peekVar :: Int -> Parser ELabel 79 | peekVar ix = do 80 | stack <- varStack <$> getState 81 | let len = length stack 82 | if ix >= 2 * len 83 | then do 84 | vars <- forM [0 .. div ix 2 - len - 1] $ const $ appendBlock (False, False) 85 | newVar <- 86 | if even ix 87 | then do 88 | (Just var, Nothing) <- appendBlock (True, False) 89 | return var 90 | else do 91 | (Nothing, Just var) <- appendBlock (False, True) 92 | return var 93 | return $ message stack newVar 94 | else 95 | let (var1, var2) = stack !! div ix 2 96 | maybeVar = if even ix then var1 else var2 97 | in case maybeVar of 98 | Just var -> return $ message stack var 99 | Nothing -> do 100 | var <- putVarAt ix 101 | return $ message stack var 102 | where message stack var = trace' 2 ("peeked " ++ show ix ++ " from " ++ show stack ++ ", got " ++ show var) var 103 | 104 | -- Pop a 2-variable block off the stack 105 | popBlock :: Parser (Maybe ELabel, Maybe ELabel) 106 | popBlock = do 107 | stat <- getState 108 | let stack = varStack stat 109 | putState stat{varStack = trace' 2 ("popping from " ++ show stack) $ tail stack} 110 | return $ head stack 111 | 112 | -- Parse a right paren or be at end of line 113 | rParen :: Parser () 114 | rParen = (char ')' >> return ()) <|> (lookAhead endOfLine >> return ()) <|> lookAhead eof 115 | 116 | -- Eat a lone space character (not followed by sub- or superscipt) 117 | soleSpace :: Parser () 118 | soleSpace = try $ char ' ' >> notFollowedBy (oneOf "⁰¹²³⁴⁵⁶⁷⁸⁹₀₁₂₃₄₅₆₇₈₉") 119 | 120 | -- List of builtins applied to overflowing line numbers 121 | lineFuncs :: [Exp [Lit Scheme]] 122 | lineFuncs = [bins "argdup", 123 | bins "flip", 124 | bins "map", 125 | bins "zip", 126 | bins "hook"] 127 | 128 | -- Parse a multiline expression, where some lines are marked with a leading space 129 | multiline :: Parser [Exp [Lit Scheme]] 130 | multiline = do 131 | lineExprs <- sepBy1 (try markedLine <|> unmarkedLine) endOfLine 132 | numLn <- numLines <$> getState 133 | unmarkeds <- unmarked <$> getState 134 | return $ map (updateLineNums numLn unmarkeds) lineExprs 135 | where markedLine = do 136 | soleSpace 137 | expr <- lineExpr 138 | stat <- getState 139 | putState stat{numLines = numLines stat + 1} 140 | return (True, expr) 141 | unmarkedLine = do 142 | expr <- lineExpr 143 | stat <- getState 144 | putState stat{unmarked = unmarked stat ++ [numLines stat], 145 | numLines = numLines stat + 1} 146 | return (False, expr) 147 | updateLineNums numLn unmark (marked, expr) = go expr 148 | where numUnmark = length unmark 149 | go (ELine n) 150 | | marked, lNum <- mod n numLn, rounds <- div n numLn = 151 | case rounds of 0 -> ELine lNum 152 | k -> EApp (lineFuncs !! (k-1)) $ ELine lNum 153 | | lNum <- mod n numUnmark, rounds <- div n numUnmark = 154 | case rounds of 0 -> ELine (unmark !! lNum) 155 | k -> EApp (lineFuncs !! (k-1)) $ ELine (unmark !! lNum) 156 | go (EApp e1 e2) = EApp (go e1) (go e2) 157 | go (EOp e1 e2 e3) = EOp (go e1) (go e2) (go e3) 158 | go (EAbs name exp) = EAbs name (go exp) 159 | go (ELet name exp body) = ELet name (go exp) (go body) 160 | go e = e 161 | 162 | -- Parse a line of Husk code 163 | lineExpr :: Parser (Exp [Lit Scheme]) 164 | lineExpr = do 165 | state <- getState 166 | putState state{varStack = []} 167 | expr <- expression 168 | overflowVars <- varStack <$> getState 169 | lambdified <- lambdify expr $ trace' 2 ("lambdifying " ++ show expr ++ " with " ++ show overflowVars) overflowVars 170 | return $ trace' 2 (show lambdified) lambdified 171 | 172 | -- Add blocks of lambdas to an expression 173 | lambdify :: Exp [Lit Scheme] -> [(Maybe String, Maybe String)] -> Parser (Exp [Lit Scheme]) 174 | lambdify expr pairs = go expr (reverse pairs) [] 175 | where go expr ((Just var1, Just var2) : rest) vars = do 176 | innerExpr <- go expr rest (vars ++ [EVar var2]) 177 | return $ EAbs var2 $ ELet var1 (EApp (bins "flipap") $ EVar var2) innerExpr 178 | go expr ((Just var1, Nothing) : rest) vars = do 179 | innerExpr <- go expr rest vars 180 | return $ EAbs var1 innerExpr 181 | go expr ((Nothing, Just var2) : rest) vars = do 182 | innerExpr <- go expr rest (vars ++ [EVar var2]) 183 | return $ EAbs var2 innerExpr 184 | go expr ((Nothing, Nothing) : rest) vars = do 185 | var <- genVar "c" 186 | innerExpr <- go expr rest vars 187 | return $ EAbs (var ++ "_") innerExpr 188 | go expr [] vars = return $ foldl EApp expr vars 189 | 190 | -- Parse an expression 191 | expression :: Parser (Exp [Lit Scheme]) 192 | expression = mkPrattParser opTable term 193 | where term = between (char '(') rParen expression <|> builtin <|> try float <|> integer <|> character <|> str <|> comprstr <|> intseq <|> lambda <|> try lambdaArg <|> subscript 194 | opTable = [[InfixL $ optional soleSpace >> return (EOp invisibleOp)]] 195 | invisibleOp = bins "com4 com3 com2 com app" 196 | 197 | -- Parse a builtin 198 | builtin :: Parser (Exp [Lit Scheme]) 199 | builtin = do 200 | label <- oneOf commands 201 | return $ cmd label 202 | 203 | -- Parse an integer 204 | integer :: Parser (Exp [Lit Scheme]) 205 | integer = do 206 | digits <- many1 digit 207 | return $ ELit [Value digits numType] 208 | where numType = Scheme [] $ CType [] $ TConc TNum 209 | 210 | -- Parse a float 211 | float :: Parser (Exp [Lit Scheme]) 212 | float = do 213 | prefix <- many digit 214 | char '.' 215 | suffix <- many digit 216 | case (prefix,suffix) of 217 | ("","") -> return $ ELit [Value "0.5" numType] 218 | (_ ,"") -> return $ ELit [Value (prefix ++ ".5") numType] 219 | ("", _) -> return $ ELit [Value ("0." ++ suffix) numType] 220 | (_ , _) -> return $ ELit [Value (prefix ++ "." ++ suffix) numType] 221 | where numType = Scheme [] $ CType [] $ TConc TNum 222 | 223 | -- Parse a character 224 | character :: Parser (Exp [Lit Scheme]) 225 | character = do 226 | quote <- char '\'' 227 | coded <- anyChar 228 | let c :: Char 229 | c = toEnum $ findByte coded 230 | return $ ELit [Value (show c) $ Scheme [] $ CType [] $ TConc TChar] 231 | 232 | -- Parse a string 233 | str :: Parser (Exp [Lit Scheme]) 234 | str = do 235 | quote <- char '"' 236 | s <- content 237 | quote2 <- (char '"' >> return ()) <|> (lookAhead endOfLine >> return ()) <|> lookAhead eof 238 | return $ ELit [Value (show s) $ Scheme [] $ CType [] $ TList (TConc TChar)] 239 | where 240 | content = do 241 | codedText <- many $ noneOf "\"\n\\" 242 | plainText <- return $ map decode codedText 243 | maybeEscape <- optionMaybe $ char '\\' >> anyChar 244 | case maybeEscape of 245 | Nothing -> return plainText 246 | Just c -> do plainText2 <- content; return $ plainText ++ toEnum (findByte c) : plainText2 247 | decode '¶' = '\n' 248 | decode '¨' = '"' 249 | decode '¦' = '\\' 250 | decode c = toEnum $ findByte c 251 | 252 | -- Parse a compressed string 253 | comprstr :: Parser (Exp [Lit Scheme]) 254 | comprstr = do 255 | quote <- char '¨' 256 | s <- content 257 | quote2 <- (char '¨' >> return ()) <|> (lookAhead endOfLine >> return ()) <|> lookAhead eof 258 | return $ ELit [Value (show $ s) $ Scheme [] $CType [] $ TList (TConc TChar)] 259 | where 260 | content = do 261 | comprText <- many $ noneOf "¨\n" 262 | decomprText <- return $ decompressString comprText 263 | return $ map decode decomprText 264 | decode '¶' = '\n' 265 | decode c = c 266 | 267 | -- Parse an integer sequence 268 | intseq :: Parser (Exp [Lit Scheme]) 269 | intseq = do 270 | iseqCommand <- char 'İ' 271 | seqId <- anyChar 272 | return $ EApp (bins "intseq") $ ELit [Value (show seqId) $ Scheme [] $ CType [] $ TConc TChar] 273 | 274 | -- Parse a generalized lambda 275 | lambda :: Parser (Exp [Lit Scheme]) 276 | lambda = do 277 | lam <- oneOf "λμξφψχ" 278 | let blocks = case lam of 279 | 'λ' -> 1 280 | 'μ' -> 2 281 | 'ξ' -> 3 282 | 'φ' -> 1 283 | 'ψ' -> 2 284 | 'χ' -> 3 285 | expr <- wrap expression blocks 286 | rParen 287 | return $ if lam `elem` "φψχ" then EApp (bins "fix") expr else expr 288 | where 289 | wrap parser blocks = do 290 | sequence $ replicate blocks $ pushBlock (False, False) 291 | expr <- parser 292 | vars <- sequence $ replicate blocks popBlock 293 | lambdify expr vars 294 | 295 | -- Parse a lambda argument 296 | lambdaArg :: Parser (Exp [Lit Scheme]) 297 | lambdaArg = do 298 | supStr <- try (pure <$> oneOf sups) <|> (char ' ' >> many1 (oneOf sups)) 299 | let digits = catMaybes $ (`elemIndex` sups) <$> supStr 300 | supNum = foldl1 (\n d -> 10*n + d) digits 301 | var <- peekVar supNum 302 | return $ EVar var 303 | where sups = "⁰¹²³⁴⁵⁶⁷⁸⁹" 304 | 305 | -- Parse a subscript; used as line numbers 306 | subscript :: Parser (Exp [Lit Scheme]) 307 | subscript = do 308 | subStr <- try (pure <$> oneOf subs) <|> (char ' ' >> many1 (oneOf subs)) 309 | let digits = catMaybes $ (`elemIndex` subs) <$> subStr 310 | subNum = foldl1 (\n d -> 10*n + d) digits 311 | return $ ELine subNum 312 | where subs = "₀₁₂₃₄₅₆₇₈₉" 313 | -------------------------------------------------------------------------------- /Infer.hs: -------------------------------------------------------------------------------- 1 | 2 | -- Backtracking Damas-Milner-style type inference engine (algorithm W) 3 | -- Modified from https://github.com/wh5a/Algorithm-W-Step-By-Step 4 | 5 | {-# LANGUAGE FlexibleInstances #-} 6 | 7 | module Infer where 8 | 9 | import Debug 10 | import Expr 11 | import qualified Data.Set as Set 12 | import Data.Set ((\\)) 13 | import qualified Data.Map as Map 14 | import Data.List (nub, unzip3) 15 | import Control.Monad.State 16 | import Control.Monad (when, guard, forM_) 17 | 18 | -- Possible results for enforcing a typeclass 19 | data Enforce = Enforce {otherCons :: [TClass], -- "simpler" typeclass constraints 20 | otherUnis :: [(Type, Type)]} -- types to be unified 21 | deriving (Show) 22 | 23 | -- Find a nesting depth at which list-nested t1 equals t2 24 | eqDepth :: Type -> Type -> Maybe Int 25 | eqDepth t1 t2 | t1 == t2 = Just 0 26 | eqDepth (TList t1) (TList t2) = eqDepth t1 t2 27 | eqDepth t1 (TList t2) = succ <$> eqDepth t1 t2 28 | eqDepth _ _ = Nothing 29 | 30 | -- Find a nesting depth at which list-nested t1 could possibly be unified with t2 31 | uniDepth :: Type -> Type -> Maybe Int 32 | uniDepth t1 t2 | unifiable t1 t2 = Just 0 33 | where unifiable (TVar _) _ = True 34 | unifiable _ (TVar _) = True 35 | unifiable t1@(TConc _) t2@(TConc _) = t1 == t2 36 | unifiable (TPair l1 r1) (TPair l2 r2) = unifiable l1 l2 && unifiable r1 r2 37 | unifiable (TList t1) (TList t2) = unifiable t1 t2 38 | unifiable (TFun a1 r1) (TFun a2 r2) = unifiable a1 a2 && unifiable r1 r2 39 | unifiable _ _ = False 40 | uniDepth (TList t1) (TList t2) = uniDepth t1 t2 41 | uniDepth t1 (TList t2) = succ <$> uniDepth t1 t2 42 | uniDepth _ _ = Nothing 43 | 44 | -- Check typeclass constraint, return constraints and unifications to be enforced 45 | -- "Nothing" means the constraint failed 46 | holds :: TClass -> Maybe Enforce 47 | holds c@(Concrete (TVar _)) = Just $ Enforce [c] [] 48 | holds (Concrete (TConc _)) = Just $ Enforce [] [] 49 | holds (Concrete (TList t)) = holds (Concrete t) 50 | holds (Concrete (TPair t1 t2)) = do 51 | Enforce h1 _ <- holds (Concrete t1) 52 | Enforce h2 _ <- holds (Concrete t2) 53 | return $ Enforce (h1 ++ h2) [] 54 | holds (Concrete (TFun _ _)) = Nothing 55 | 56 | holds c@(Vect t1 t2 s1 s2) 57 | | s1 == t1, s2 == t2 = Just $ Enforce [] [] 58 | | Nothing <- uniDepth t1 s1 = Nothing 59 | | Nothing <- uniDepth t2 s2 = Nothing 60 | | Just n <- eqDepth t1 s1 = Just $ Enforce [] [(iterate TList t2 !! n, s2)] 61 | | Just n <- eqDepth t2 s2 = Just $ Enforce [] [(iterate TList t1 !! n, s1)] 62 | | otherwise = Just $ Enforce [c] [] 63 | 64 | holds c@(Vect2 t1 t2 t3 s1 s2 s3) 65 | | TList _ <- t1 = Nothing 66 | | TList _ <- t2 = Nothing 67 | | TFun _ _ <- t1 = Nothing 68 | | TFun _ _ <- t2 = Nothing 69 | | TFun _ _ <- t3 = Nothing 70 | | TFun _ _ <- s1 = Nothing 71 | | TFun _ _ <- s2 = Nothing 72 | | TFun _ _ <- s3 = Nothing -- Lists and functions are not bi-vectorizable for now 73 | | s1 == t1, s2 == t2, s3 == t3 = Just $ Enforce [] [] 74 | | Nothing <- uniDepth t1 s1 = Nothing 75 | | Nothing <- uniDepth t2 s2 = Nothing 76 | | Nothing <- uniDepth t3 s3 = Nothing 77 | | Just n1 <- eqDepth t1 s1, 78 | Just n2 <- eqDepth t2 s2 = Just $ Enforce [] [(iterate TList t3 !! max n1 n2, s3)] 79 | | Just n1 <- eqDepth t1 s1, 80 | Just n3 <- eqDepth t3 s3, 81 | n1 < n3 = Just $ Enforce [] [(iterate TList t2 !! n3, s2)] 82 | | Just n2 <- eqDepth t2 s2, 83 | Just n3 <- eqDepth t3 s3, 84 | n2 < n3 = Just $ Enforce [] [(iterate TList t1 !! n3, s1)] 85 | | otherwise = Just $ Enforce [c] [] 86 | 87 | -- Default typeclass instances, given as unifiable pairs of types 88 | -- The choice is nondeterministic, which is modeled by a list of possibilities 89 | defInst :: TClass -> [[(Type, Type)]] 90 | defInst (Concrete t) = [[(t, TConc TNum)]] 91 | defInst (Vect t1 t2 s1 s2) = [[(s1, iterate TList t1 !! max n1 n2) 92 | ,(s2, iterate TList t2 !! max n1 n2)]] 93 | where Just n1 = uniDepth t1 s1 94 | Just n2 = uniDepth t2 s2 95 | defInst (Vect2 t1 t2 t3 s1 s2 s3) = [ [(s1, iterate TList t1 !! k1) 96 | ,(s2, iterate TList t2 !! k2) 97 | ,(s3, iterate TList t3 !! max k1 k2)] 98 | | k1 <- [maxN, maxN-1 .. n1] 99 | , k2 <- [maxN, maxN-1 .. n2]] 100 | where Just n1 = uniDepth t1 s1 101 | Just n2 = uniDepth t2 s2 102 | Just n3 = uniDepth t3 s3 103 | maxN = maximum [n1, n2, n3] 104 | 105 | -- Type substitution: map from type vars to types 106 | type Sub = Map.Map TLabel Type 107 | 108 | -- Empty substitution 109 | nullSub :: Sub 110 | nullSub = Map.empty 111 | 112 | -- Composition of substitutions 113 | composeSub :: Sub -> Sub -> Sub 114 | composeSub s1 s2 = Map.map (applySub s2) s1 `Map.union` Map.map (applySub s1) s2 115 | 116 | -- Things that have type vars and support substitution 117 | class Types a where 118 | freeVars :: a -> Set.Set TLabel 119 | applySub :: Sub -> a -> a 120 | 121 | instance Types Type where 122 | freeVars (TVar n) = Set.singleton n 123 | freeVars (TFun t1 t2) = freeVars t1 `Set.union` freeVars t2 124 | freeVars (TPair t1 t2) = freeVars t1 `Set.union` freeVars t2 125 | freeVars (TList t) = freeVars t 126 | freeVars _ = Set.empty 127 | applySub s (TVar n) = case Map.lookup n s of 128 | Nothing -> TVar n 129 | Just t -> t 130 | applySub s (TFun t1 t2) = TFun (applySub s t1) (applySub s t2) 131 | applySub s (TPair t1 t2) = TPair (applySub s t1) (applySub s t2) 132 | applySub s (TList t) = TList $ applySub s t 133 | applySub _ t = t 134 | 135 | instance Types TClass where 136 | freeVars (Concrete t) = freeVars t 137 | freeVars (Vect t1 t2 s1 s2) = freeVars [t1,t2,s1,s2] 138 | freeVars (Vect2 t1 t2 t3 s1 s2 s3) = freeVars [t1,t2,t3,s1,s2,s3] 139 | applySub s (Concrete t) = Concrete $ applySub s t 140 | applySub s (Vect t1 t2 s1 s2) = Vect (applySub s t1) (applySub s t2) (applySub s s1) (applySub s s2) 141 | applySub s (Vect2 t1 t2 t3 s1 s2 s3) = 142 | Vect2 (applySub s t1) (applySub s t2) (applySub s t3) (applySub s s1) (applySub s s2) (applySub s s3) 143 | 144 | instance Types CType where 145 | freeVars (CType _ typ) = freeVars typ -- TODO: is this correct? 146 | applySub s (CType cons typ) = CType (applySub s cons) (applySub s typ) 147 | 148 | instance Types Scheme where 149 | freeVars (Scheme vars t) = freeVars t \\ Set.fromList vars 150 | applySub s (Scheme vars t) = Scheme vars $ applySub (foldr Map.delete s vars) t 151 | 152 | instance (Types a) => Types (Lit a) where 153 | freeVars (Value _ typ) = freeVars typ 154 | freeVars (Builtin _ typ) = freeVars typ 155 | freeVars (Vec typ) = freeVars typ 156 | freeVars (Vec2 _ typ) = freeVars typ 157 | applySub s (Value name typ) = Value name $ applySub s typ 158 | applySub s (Builtin name typ) = Builtin name $ applySub s typ 159 | applySub s (Vec typ) = Vec $ applySub s typ 160 | applySub s (Vec2 kind typ) = Vec2 kind $ applySub s typ 161 | 162 | instance (Types a) => Types (Exp (Lit a)) where 163 | freeVars _ = error "freeVars not implemented for expressions" 164 | applySub s = fmap $ applySub s 165 | 166 | instance (Types a) => Types [a] where 167 | freeVars l = foldr Set.union Set.empty $ map freeVars l 168 | applySub s = map $ applySub s 169 | 170 | -- Type environment: types of expression variables 171 | newtype TypeEnv = TypeEnv (Map.Map ELabel Scheme) 172 | deriving (Show) 173 | 174 | instance Types TypeEnv where 175 | freeVars (TypeEnv env) = freeVars $ Map.elems env 176 | applySub s (TypeEnv env) = TypeEnv $ Map.map (applySub s) env 177 | 178 | -- Remove binding from environment 179 | remove :: TypeEnv -> ELabel -> TypeEnv 180 | remove (TypeEnv env) var = TypeEnv $ Map.delete var env 181 | 182 | -- Universally quantify all type variables in type that are not bound in environment 183 | generalize :: TypeEnv -> CType -> Scheme 184 | generalize env ct = Scheme vars ct 185 | where vars = Set.toList $ freeVars ct \\ freeVars env 186 | 187 | -- Type for line functions with possibly inferred type 188 | data LineFunc = Unprocessed (Exp [Lit Scheme]) 189 | | Processing Type 190 | | Processed (Exp (Lit CType)) CType 191 | deriving (Show) 192 | 193 | -- State for generating unique type vars 194 | data InfState = InfState {varSupply :: Int, 195 | currSubst :: Sub, 196 | lineExprs :: Map.Map Int LineFunc} 197 | 198 | -- Monad for performing backtracking type inference 199 | type Infer a = StateT InfState [] a 200 | 201 | -- Run a monadic computation with Infer, using given set of lines 202 | runInfer :: [Exp [Lit Scheme]] -> Infer a -> [(a, InfState)] 203 | runInfer exps t = runStateT t initState 204 | where initState = InfState {varSupply = 0, 205 | currSubst = nullSub, 206 | lineExprs = Map.fromList [(i, Unprocessed e) | (i, e) <- zip [0..] exps]} 207 | 208 | -- Generate a new type variable 209 | newTVar :: String -> Infer Type 210 | newTVar prefix = do 211 | s <- get 212 | put s{varSupply = varSupply s + 1} 213 | return $ TVar $ prefix ++ show (varSupply s) 214 | 215 | -- Update current substitution with new one 216 | updateSub :: Sub -> Infer () 217 | updateSub sub = do 218 | s <- get 219 | put s{currSubst = currSubst s `composeSub` sub} 220 | 221 | -- Update line functions 222 | updateLines :: (Map.Map Int LineFunc -> Map.Map Int LineFunc) -> Infer () 223 | updateLines f = do 224 | s <- get 225 | put s{lineExprs = f $ lineExprs s} 226 | 227 | -- Apply current substitution 228 | substitute :: (Show t, Types t) => t -> Infer t 229 | substitute t = do 230 | sub <- gets currSubst 231 | return $ trace' 2 ("substituting " ++ show t ++ " with " ++ show (Map.toList sub)) $ applySub sub t 232 | 233 | -- Replace all bound variables with newly generated ones 234 | instantiate :: Scheme -> Infer CType 235 | instantiate (Scheme vars ct) = do 236 | newVars <- mapM (\_ -> newTVar "a") vars 237 | let s = Map.fromList $ zip vars newVars 238 | return $ applySub s ct 239 | 240 | -- Bind a type variable to a type, update current substitution 241 | -- Fails if var occurs in the type (infinite type) 242 | varBind :: TLabel -> Type -> Infer () 243 | varBind name typ 244 | | TVar var <- typ, var == name = return () 245 | | name `Set.member` freeVars typ = trace' 2 "occurs check fail" $ fail "" 246 | | otherwise = updateSub $ Map.singleton name typ 247 | 248 | -- Most general unifier of two types 249 | -- Updates substitution in a way that makes them equal 250 | -- Fails if types can't be unified 251 | unify :: Type -> Type -> Infer () 252 | unify t1 t2 | trace' 2 ("unifying " ++ show t1 ++ " and " ++ show t2) False = undefined 253 | unify t1 t2 = do 254 | t1' <- substitute t1 255 | t2' <- substitute t2 256 | unify' t1' t2' 257 | where 258 | unify' (TFun arg1 res1) (TFun arg2 res2) = 259 | do unify' arg1 arg2 260 | unify res1 res2 261 | unify' (TPair l1 r1) (TPair l2 r2) = 262 | do unify' l1 l2 263 | unify r1 r2 264 | unify' (TList t1) (TList t2) = unify' t1 t2 265 | unify' (TVar name) typ = varBind name typ 266 | unify' typ (TVar name) = varBind name typ 267 | unify' (TConc a) (TConc b) | a == b = return () 268 | unify' _ _ = trace' 2 "unification fail" $ fail "" 269 | 270 | -- Check typeclass constraints; remove those that hold, keep indeterminate ones, perform unifications, fail if any don't hold 271 | checkCons :: [TClass] -> Infer [TClass] 272 | checkCons (x:_) | trace' 2 ("checking " ++ show x) False = undefined 273 | checkCons [] = return [] 274 | checkCons (c:cs) = case traceShow' 2 (c, holds c) $ holds c of 275 | Just (Enforce newCs unis) -> do 276 | mapM (uncurry unify) unis 277 | (newCs ++) <$> checkCons cs 278 | Nothing -> trace' 2 "constraint fail" $ fail "" 279 | 280 | -- Infer type of literal 281 | inferLit :: Lit Scheme -> Infer (CType, Exp (Lit CType)) 282 | inferLit x | trace' 2 ("chose " ++ show x) False = undefined 283 | inferLit lit@(Value name typ) = 284 | do newTyp <- instantiate typ 285 | return (newTyp, ELit $ Value name newTyp) 286 | inferLit lit@(Builtin name typ) = 287 | do newTyp <- instantiate typ 288 | return (newTyp, ELit $ Builtin name newTyp) 289 | inferLit lit@(Vec typ) = 290 | do newTyp <- instantiate typ 291 | return (newTyp, ELit $ Vec newTyp) 292 | inferLit lit@(Vec2 kind typ) = 293 | do newTyp <- instantiate typ 294 | return (newTyp, ELit $ Vec2 kind newTyp) 295 | 296 | -- Infer type of []-overloaded expression 297 | -- All free expression variables must be bound in environment (otherwise it crashes) 298 | -- Returns tuple of: 299 | -- type of whole expression, non-overloaded expression 300 | -- Second argument is type hint 301 | infer :: TypeEnv -> Maybe Type -> Exp [Lit Scheme] -> Infer (CType, Exp (Lit CType)) 302 | infer env _ exp | trace' 2 ("inferring " ++ show exp) False = undefined 303 | 304 | -- Variable: find type in environment, combine constraints, return type 305 | infer (TypeEnv env) _ (EVar name) = 306 | case Map.lookup name env of 307 | Nothing -> error $ "unbound variable: " ++ name 308 | Just sigma -> do typ <- instantiate sigma 309 | return (typ, EVar name) 310 | 311 | -- Line reference: pull type if already inferred, otherwise infer it 312 | infer env hint (ELine num) = 313 | do lineExpr <- gets $ (Map.! num) . lineExprs 314 | case lineExpr of 315 | Unprocessed expr -> do 316 | initTyp <- case hint of 317 | Just typ -> return typ 318 | Nothing -> newTVar "l" 319 | updateLines $ Map.insert num $ Processing initTyp 320 | (typ@(CType _ resTyp), infExpr) <- infer env hint expr 321 | unify initTyp resTyp 322 | newExpr <- substitute infExpr 323 | newTyp <- substitute typ 324 | updateLines $ Map.insert num $ Processed newExpr newTyp 325 | return (newTyp, ELine num) 326 | Processing typ -> do 327 | newTyp <- substitute typ 328 | updateLines $ Map.insert num $ Processing newTyp 329 | return (CType [] $ newTyp, ELine num) 330 | Processed exp typ -> do 331 | newTyp <- substitute typ 332 | newExp <- substitute exp 333 | updateLines $ Map.insert num $ Processed newExp newTyp 334 | return (newTyp, ELine num) 335 | 336 | 337 | -- Literal: apply helper function 338 | -- This is the only source of nondeterminism (overloaded function literals) 339 | infer _ hint (ELit lits) = do lit <- lift lits 340 | res@(CType _ typ, _) <- inferLit lit 341 | case hint of 342 | Just hintTyp -> unify typ hintTyp 343 | _ -> return () 344 | return res 345 | 346 | -- Lambda abstraction: add new unbound variable to environment, recurse to body, substitute back 347 | infer env hint (EAbs name exp) = 348 | do newVar <- case hint of 349 | Just (TFun arg _) -> return arg 350 | _ -> newTVar "b" 351 | let TypeEnv envMinusName = remove env name 352 | newEnv = TypeEnv $ Map.union envMinusName $ Map.singleton name $ Scheme [] $ CType [] newVar 353 | (CType cons typ, newExp) <- case hint of 354 | Just (TFun _ res) -> infer newEnv (Just res) exp 355 | _ -> infer newEnv Nothing exp 356 | varTyp <- substitute newVar 357 | retExp <- substitute newExp 358 | return (CType cons $ TFun varTyp typ, EAbs name retExp) 359 | 360 | -- Application: infer function type and argument type, unify with function, check and reduce constraints 361 | infer env hint exp@(EApp fun arg) = --traceShow' (fun,arg) $ 362 | do newVar <- case hint of 363 | Just typ -> return typ 364 | Nothing -> newTVar "c" 365 | (CType funCons funTyp, funExp) <- infer env Nothing fun 366 | newEnv <- substitute env 367 | (CType argCons argTyp, argExp) <- case funTyp of 368 | TFun funcArg funcRes -> do 369 | unify funcRes newVar 370 | infer newEnv (Just funcArg) arg 371 | _ -> do 372 | infer newEnv Nothing arg 373 | unify funTyp (TFun argTyp newVar) 374 | cons <- checkCons . nub =<< substitute (funCons ++ argCons) 375 | varTyp <- substitute newVar 376 | newFunExp <- substitute funExp 377 | newArgExp <- substitute argExp 378 | return (CType cons varTyp, EApp newFunExp newArgExp) 379 | 380 | -- Infix operator: infer as binary function, but in order first arg -> second arg -> operator 381 | -- If second arg is lambda or line reference, order is first -> operator -> second to take advantage of hints 382 | -- Replace with two function applications in result 383 | infer env hint exp@(EOp op argL argR) = do 384 | newVar <- case hint of 385 | Just typ -> return typ 386 | Nothing -> newTVar "c" 387 | (CType lCons lTyp, lExp) <- infer env Nothing argL 388 | newEnv <- substitute env 389 | (CType rCons rTyp, rExp) <- infer newEnv Nothing argR 390 | newEnv2 <- substitute newEnv 391 | (CType opCons opTyp, opExp) <- let opHint = Just $ TFun lTyp $ TFun rTyp newVar 392 | in infer newEnv2 opHint op 393 | unify opTyp (TFun lTyp $ TFun rTyp newVar) 394 | varTyp <- substitute newVar 395 | cons <- checkCons . nub =<< substitute (opCons ++ rCons ++ lCons) 396 | [newOpExp, newLExp, newRExp] <- mapM substitute [opExp, lExp, rExp] 397 | return (CType cons varTyp, EApp (EApp newOpExp newLExp) newRExp) 398 | 399 | -- Let binding: infer type of var from fix-enhanced exp, generalize to polytype, infer body, check and reduce constraints 400 | infer env _ (ELet name exp body) = 401 | do let fixExp = EApp fixE $ EAbs name exp 402 | (expTyp@(CType expCons _), EApp _ (EAbs _ expExp)) <- infer env Nothing fixExp 403 | subEnv <- substitute env 404 | let TypeEnv envMinusName = remove env name 405 | expPoly = generalize subEnv expTyp 406 | newEnv <- substitute $ TypeEnv $ Map.insert name expPoly envMinusName 407 | (bodyTyp@(CType bodyCons _), bodyExp) <- infer newEnv Nothing body 408 | cons <- checkCons . nub <$> substitute (expCons ++ bodyCons) 409 | newExpExp <- substitute expExp 410 | newBodyExp <- substitute bodyExp 411 | return (bodyTyp, ELet name newExpExp newBodyExp) 412 | where fixE = ELit [Builtin "fix" $ Scheme ["x"] $ CType [] $ TFun (TFun (TVar "x") (TVar "x")) (TVar "x")] 413 | 414 | -- Main type inference function, with a hint about the resulting type 415 | typeInference :: Map.Map ELabel Scheme -> Scheme -> Exp [Lit Scheme] -> Infer CType 416 | typeInference env hint expr = 417 | do CType _ hintTyp <- instantiate hint 418 | (typ, newExp) <- infer (TypeEnv env) (Just hintTyp) expr 419 | newTyp <- substitute typ 420 | return newTyp 421 | 422 | -- Prune admissible types of builtins based on local patterns 423 | prune :: Exp [Lit Scheme] -> Exp [Lit Scheme] 424 | prune (EOp (ELit ops) (ELit largs) (ELit rargs)) = EOp (selectLits newOps ops) (selectLits newLargs largs) (selectLits newRargs rargs) 425 | where (newOps, newLargs, newRargs) = 426 | unzip3 [(op, larg, rarg) | op <- ops, larg <- largs, rarg <- rargs, 427 | not . null . inferSimple $ EOp (ELit [op]) (ELit [larg]) (ELit [rarg])] 428 | prune (EOp (ELit ops) larg (ELit rargs)) = EOp (selectLits newOps ops) (prune larg) (selectLits newRargs rargs) 429 | where (newOps, newRargs) = 430 | unzip [(op, rarg) | op <- ops, rarg <- rargs, 431 | not . null . inferSimple $ EOp (ELit [op]) undef (ELit [rarg])] 432 | undef = ELit [Value "undef" $ Scheme ["x"] $ CType [] $ TVar "x"] 433 | prune (EOp op larg rarg) = EOp op (prune larg) (prune rarg) 434 | prune (EApp larg rarg) = EApp (prune larg) (prune rarg) 435 | prune (EAbs var expr) = EAbs var $ prune expr 436 | prune (ELet var expr body) = ELet var (prune expr) (prune body) 437 | prune expr = expr 438 | 439 | selectLits :: [Lit Scheme] -> [Lit Scheme] -> Exp [Lit Scheme] 440 | selectLits news olds = ELit $ filter (`elem` news) olds 441 | 442 | -- Infer types of a single expression out of context 443 | inferSimple :: Exp [Lit Scheme] -> [(CType, InfState)] 444 | inferSimple expr = runInfer [] $ typeInference Map.empty (Scheme ["x"] $ CType [] $ TVar "x") expr 445 | 446 | -- Infer types of lines under a constraint 447 | inferType :: Bool -> Scheme -> [Exp [Lit Scheme]] -> [[(Int, CType, Exp (Lit CType))]] 448 | inferType constrainRes typeConstr exprs = trace' 1 ("inferring program " ++ show pruned) $ map fst $ runInfer pruned $ do 449 | CType infCons typ <- typeInference Map.empty typeConstr (ELine 0) 450 | when constrainRes $ do 451 | CType conCons genType <- instantiate typeConstr 452 | trace' 1 "applying constraints" $ unify genType typ 453 | trace' 1 "defaulting instances" $ forM_ (nub $ infCons ++ conCons) $ \con -> do 454 | newCons <- checkCons =<< substitute [con] 455 | forM_ newCons $ \newCon -> do 456 | insts <- lift $ defInst newCon 457 | mapM_ (uncurry unify) insts 458 | lExprs <- Map.assocs <$> gets lineExprs 459 | flip mapM [(i, exp, typ) | (i, Processed exp typ) <- lExprs] $ 460 | \(i, exp, typ) -> do 461 | newExp <- substitute exp 462 | newTyp <- substitute typ 463 | return (i, newTyp, newExp) 464 | where pruned = trace' 1 ("pruning program " ++ show exprs) $ prune <$> exprs 465 | 466 | -- TESTS 467 | 468 | e0 = ELet "id" 469 | (EAbs "x" (EVar "x")) 470 | (EVar "id") 471 | 472 | e1 = ELet "id" 473 | (EAbs "x" (EVar "x")) 474 | (EApp (EVar "id") (EVar "id")) 475 | 476 | e2 = EApp 477 | (ELit [Builtin "inc" $ Scheme [] $ CType [] $ TFun (TConc TNum) (TConc TNum), 478 | Builtin "upper" $ Scheme [] $ CType [] $ TFun (TConc TChar) (TConc TChar)]) 479 | (ELit [Value "2" $ Scheme [] $ CType [] $ TConc TNum]) 480 | 481 | e3 = EApp 482 | (ELit [Builtin "inc" $ Scheme [] $ CType [] $ TFun (TConc TNum) (TConc TNum), 483 | Builtin "upper" $ Scheme [] $ CType [] $ TFun (TConc TChar) (TConc TChar)]) 484 | (ELit [Value "'a'" $ Scheme [] $ CType [] $ TConc TChar]) 485 | 486 | e4 = EApp 487 | (ELit [Builtin "mapinc" $ Scheme [] $ CType [] $ TFun (TList (TConc TNum)) (TList (TConc TNum)), 488 | Builtin "not" $ Scheme ["x"] $ CType [Concrete (TVar "x")] $ TFun (TVar "x") (TConc TNum)]) 489 | (ELit [Value "[1]" $ Scheme [] $ CType [] $ TList (TConc TNum)]) 490 | 491 | e5 = EAbs "f" $ 492 | ELet "x" 493 | (EApp (EVar "f") (EVar "x")) 494 | (EVar "x") 495 | 496 | e6 = EApp 497 | (EApp 498 | (ELit [Builtin "com" $ Scheme ["a","b","c"] $ CType [] $ (TVar "b" ~> TVar "c") ~> (TVar "a" ~> TVar "b") ~> (TVar "a" ~> TVar "c")]) 499 | (ELit [Builtin "consume" $ Scheme ["x"] $ CType [Concrete (TVar "x")] $ TVar "x" ~> TConc TNum])) 500 | (ELit [Builtin "produce" $ Scheme ["x"] $ CType [Concrete (TVar "x")] $ TConc TNum ~> TVar "x"]) 501 | 502 | e7 = EApp 503 | (ELit [Builtin "vecneg" $ Scheme ["a","b"] $ CType [Vect (TConc TNum) (TConc TNum) (TVar "a") (TVar "b")] $ TVar "a" ~> TVar "b"]) 504 | (ELit [Value "[[[1]]]" $ Scheme [] $ CType [] $ TList (TList (TList (TConc TNum)))]) 505 | -------------------------------------------------------------------------------- /Builtins.hs: -------------------------------------------------------------------------------- 1 | module Builtins (bins, cmd, commands) where 2 | 3 | import Expr 4 | 5 | -- Utilities for writing types 6 | [x,y,z,u,v,w,t,n,m] = map (TVar . pure) "xyzuvwtnm" 7 | 8 | num :: Type 9 | num = TConc TNum 10 | 11 | chr :: Type 12 | chr = TConc TChar 13 | 14 | lst :: Type -> Type 15 | lst = TList 16 | 17 | tup :: Type -> Type -> Type 18 | tup = TPair 19 | 20 | con :: Type -> TClass 21 | con = Concrete 22 | 23 | vec :: Type -> Type -> Type -> Type -> TClass 24 | vec = Vect 25 | 26 | vec2 :: Type -> Type -> Type -> Type -> Type -> Type -> TClass 27 | vec2 = Vect2 28 | 29 | forall :: String -> [TClass] -> Type -> Scheme 30 | forall vars cons typ = Scheme (map pure vars) $ CType cons typ 31 | 32 | simply :: Type -> Scheme 33 | simply typ = forall "" [] typ 34 | 35 | -- Compute command from char 36 | cmd :: Char -> Exp [Lit Scheme] 37 | cmd char | Just exp <- lookup char commandsList = exp 38 | cmd char = error $ "No builtin bound to character " ++ [char] 39 | 40 | -- List of commands 41 | commands :: String 42 | commands = map fst commandsList 43 | 44 | -- Unused characters: ∟¿⌐$@HZ[]bjlq{}ΔΦαβγζθρςτχψȦḂĖḢĿṄẆẎŻȧḃċıȷṅẇẋẏÄÏÜŸØäïÿ◊ 45 | 46 | -- Assoc list of commands that can occur in source 47 | commandsList :: [(Char, Exp [Lit Scheme])] 48 | commandsList = [ 49 | ('+', bins "add cat"), 50 | ('-', bins "sub diffl del"), 51 | ('*', bins "mul replen repln' cart2 ccons csnoc"), 52 | ('/', bins "div"), 53 | ('÷', bins "idiv"), 54 | ('%', bins "mod"), 55 | ('_', bins "neg tolowr"), 56 | ('\\', bins "inv swcase"), 57 | (';', bins "pure"), 58 | (',', bins "pair"), 59 | (':', bins "cons snoc"), 60 | ('m', bins "map mapr maptp"), 61 | ('z', bins "zip"), 62 | ('F', bins "foldl foldl1 aptp"), 63 | ('Ḟ', bins "foldr foldr1 apftp"), 64 | ('G', bins "scanl scanl1 scltp"), 65 | ('Ġ', bins "scanr scanr1 scrtp"), 66 | ('f', bins "filter select"), 67 | ('L', bins "len nlen"), 68 | ('#', bins "countf count count' count2"), 69 | ('N', bins "nats"), 70 | ('!', bins "index index2 idx2d idx2d2"), 71 | ('↑', bins "take take2 takew"), 72 | ('↓', bins "drop drop2 dropw"), 73 | ('↕', bins "span"), 74 | ('←', bins "head fst predN predC"), 75 | ('→', bins "last snd succN succC"), 76 | ('↔', bins "swap rev revnum"), 77 | ('h', bins "init"), 78 | ('t', bins "tail"), 79 | ('ƒ', bins "fix"), 80 | ('ω', bins "fixp fixpL"), 81 | ('<', bins "lt"), 82 | ('>', bins "gt"), 83 | ('≤', bins "le"), 84 | ('≥', bins "ge"), 85 | ('=', bins "eq"), 86 | ('≠', bins "neq"), 87 | ('?', bins "if if2 fif"), 88 | ('¬', bins "not"), 89 | ('|', bins "or or'"), 90 | ('&', bins "and and'"), 91 | ('S', bins "hook bhook"), 92 | ('Ṡ', bins "hookf bhookf"), 93 | ('K', bins "const"), 94 | ('I', bins "id"), 95 | ('`', bins "flip"), 96 | ('Γ', bins "list listN listF listNF"), 97 | ('Σ', bins "sum chrsum trian concat"), 98 | ('Π', bins "prod fact cartes"), 99 | ('§', bins "fork fork2"), 100 | ('´', bins "argdup"), 101 | ('∞', bins "rep"), 102 | ('¡', bins "iter iterP iterL iter2"), 103 | ('c', bins "chr ord"), 104 | ('s', bins "show"), 105 | ('r', bins "read"), 106 | ('ø', bins "empty"), 107 | ('€', bins "elem elem' subl"), 108 | ('o', bins "com com2 com3 com4"), 109 | ('ȯ', EAbs "x" $ EAbs "y" $ EAbs "z" $ 110 | EOp (bins "com com2 com3 com4") (EVar "x") $ 111 | EOp (bins "com com2 com3 com4") (EVar "y") (EVar "z")), 112 | ('ö', EAbs "x" $ EAbs "y" $ EAbs "z" $ EAbs "u" $ 113 | EOp (bins "com com2 com3 com4") (EVar "x") $ 114 | EOp (bins "com com2 com3 com4") (EVar "y") $ 115 | EOp (bins "com com2 com3 com4") (EVar "z") (EVar "u")), 116 | ('†', bins "vec"), 117 | ('‡', bins "vec2"), 118 | ('O', bins "sort"), 119 | ('Ö', bins "sorton sortby"), 120 | ('▲', bins "maxl"), 121 | ('▼', bins "minl"), 122 | ('u', bins "nub"), 123 | ('ü', bins "nubon nubby"), 124 | ('U', bins "nubw nubwN"), 125 | ('w', bins "words unwords uwshow uwpshw"), 126 | ('¶', bins "lines unlines ulshow ulpshw"), 127 | ('p', bins "pfac"), 128 | ('σ', bins "subs subs2"), 129 | ('g', bins "group"), 130 | ('ġ', bins "groupOn groupBy"), 131 | ('ḣ', bins "heads"), 132 | ('ṫ', bins "tails"), 133 | ('¦', bins "divds subset"), 134 | ('P', bins "perms"), 135 | ('V', bins "any any2"), 136 | ('Λ', bins "all all2"), 137 | ('T', bins "trsp trspw unzip"), 138 | ('ż', bins "zip'"), 139 | ('ṁ', bins "cmap cmapr smap smapr"), 140 | ('≡', bins "congr"), 141 | ('¤', bins "combin"), 142 | ('i', bins "n2i c2i s2i"), 143 | ('e', bins "list2"), 144 | ('ė', bins "list3"), 145 | ('ë', bins "list4"), 146 | ('Ṫ', bins "table"), 147 | ('Ṁ', bins "rmap rmaptp"), 148 | ('M', bins "lmap lmaptp"), 149 | ('«', bins "mapacL"), 150 | ('»', bins "mapacR"), 151 | ('R', bins "replic replif"), 152 | ('a', bins "abs touppr"), 153 | ('±', bins "sign isdigt"), 154 | ('B', bins "base abase"), 155 | ('d', bins "base10 abas10"), 156 | ('ḋ', bins "base2 abase2"), 157 | ('D', bins "double isuppr doubL"), 158 | ('½', bins "halve islowr halfL"), 159 | ('^', bins "power"), 160 | ('□', bins "square isanum"), 161 | ('√', bins "sqrt isalph"), 162 | ('C', bins "cut cut2 cuts cutL"), 163 | ('X', bins "slice"), 164 | ('Ẋ', bins "mapad2 mapad3"), 165 | ('J', bins "join join' joinE joinV"), 166 | ('Ṗ', bins "powset powstN"), 167 | ('×', bins "mix"), 168 | ('£', bins "oelem oelem'"), 169 | ('ṗ', bins "isprime"), 170 | ('Q', bins "slices"), 171 | ('Ṙ', bins "clone clone' clones"), 172 | ('¢', bins "cycle"), 173 | ('∫', bins "cumsum cumcat"), 174 | ('⌈', bins "ceil"), 175 | ('⌊', bins "floor"), 176 | ('⌋', bins "gcd"), 177 | ('⌉', bins "lcm"), 178 | ('ε', bins "small single"), 179 | ('‰', bins "divmod"), 180 | ('‼', bins "twice"), 181 | ('…', bins "rangeN rangeC rangeL rangeS"), 182 | ('ḟ', bins "find findN"), 183 | ('E', bins "same"), 184 | ('~', bins "branch"), 185 | ('ṙ', bins "rotate rotatf"), 186 | ('Ω', bins "until"), 187 | ('Ḋ', bins "divs"), 188 | ('δ', bins "decorM decorL decorV decorN"), 189 | ('Θ', bins "prep0"), 190 | ('Ξ', bins "merge"), 191 | ('≈', bins "simil"), 192 | ('◄', bins "minlby minlon"), 193 | ('►', bins "maxlby maxlon"), 194 | ('∂', bins "adiags"), 195 | ('ŀ', bins "lrange ixes"), 196 | ('ṡ', bins "srange rvixes"), 197 | ('π', bins "cpow cpow' cpowN"), 198 | ('Ψ', bins "toadjM toadjL toadjV toadjN"), 199 | ('Ë', bins "sameon sameby"), 200 | ('k', bins "keyon keyby"), 201 | ('x', bins "split split' splitL"), 202 | ('A', bins "mean"), 203 | ('n', bins "bwand isect"), 204 | ('v', bins "bwor union ucons usnoc"), 205 | ('·', bins "comf comf2 comf3 comf4"), 206 | ('Ċ', bins "gaps gaps2 gapsL"), 207 | ('y', bins "min"), 208 | ('Y', bins "max"), 209 | ('η', bins "onixes"), 210 | ('¥', bins "ixsof ixsof2"), 211 | ('W', bins "where where2") 212 | ] 213 | 214 | -- Compute builtins from space-delimited list 215 | bins :: String -> Exp [Lit Scheme] 216 | bins names = ELit $ map getBuiltin $ words names 217 | where getBuiltin "vec" = Vec $ forall "xyuv" [vec x y u v] $ (x ~> y) ~> (u ~> v) 218 | getBuiltin "vec2" = Vec2 False $ forall "xyzuvw" [vec2 x y z u v w] $ (x ~> y ~> z) ~> (u ~> v ~> w) 219 | getBuiltin "vec2'" = Vec2 True $ forall "xuvw" [vec2 x x x u v w] $ (x ~> x ~> x) ~> (u ~> v ~> w) 220 | getBuiltin name | Just typ <- lookup name builtinsList = Builtin name typ 221 | getBuiltin name = error $ "No builtin named " ++ name 222 | 223 | -- Assoc list of builtins 224 | builtinsList :: [(String, Scheme)] 225 | builtinsList = [ 226 | 227 | ("intseq", simply $ chr ~> lst num), 228 | 229 | -- Arithmetic 230 | ("add", simply $ num ~> num ~> num), 231 | ("sub", simply $ num ~> num ~> num), 232 | ("mul", simply $ num ~> num ~> num), 233 | ("div", simply $ num ~> num ~> num), 234 | ("idiv", simply $ num ~> num ~> num), 235 | ("mod", simply $ num ~> num ~> num), 236 | ("neg", simply $ num ~> num), 237 | ("inv", simply $ num ~> num), 238 | ("trian", simply $ num ~> num), 239 | ("fact", simply $ num ~> num), 240 | ("predN", simply $ num ~> num), 241 | ("succN", simply $ num ~> num), 242 | ("pfac", simply $ num ~> lst num), 243 | ("divds", simply $ num ~> num ~> num), 244 | ("sign", simply $ num ~> num), 245 | ("abs", simply $ num ~> num), 246 | ("base", simply $ num ~> num ~> lst num), 247 | ("base2", simply $ num ~> lst num), 248 | ("base10",simply $ num ~> lst num), 249 | ("abase", simply $ num ~> lst num ~> num), 250 | ("abase2",simply $ lst num ~> num), 251 | ("abas10",simply $ lst num ~> num), 252 | ("double",simply $ num ~> num), 253 | ("halve", simply $ num ~> num), 254 | ("power", simply $ num ~> num ~> num), 255 | ("square",simply $ num ~> num), 256 | ("sqrt", simply $ num ~> num), 257 | ("isprime",simply$ num ~> num), 258 | ("ceil", simply $ num ~> num), 259 | ("floor", simply $ num ~> num), 260 | ("gcd", simply $ num ~> num ~> num), 261 | ("lcm", simply $ num ~> num ~> num), 262 | ("small", simply $ num ~> num), 263 | ("divmod",simply $ num ~> num ~> lst num), 264 | ("divs", simply $ num ~> lst num), 265 | ("bwand", simply $ num ~> num ~> num), 266 | ("bwor", simply $ num ~> num ~> num), 267 | ("revnum",simply $ num ~> num), 268 | 269 | -- List and pair manipulation 270 | ("empty", forall "x" [] $ lst x), 271 | ("pure", forall "x" [] $ x ~> lst x), 272 | ("pair", forall "xy" [] $ x ~> y ~> tup x y), 273 | ("swap", forall "xy" [] $ tup x y ~> tup y x), 274 | ("cons", forall "x" [] $ x ~> lst x ~> lst x), 275 | ("cat", forall "x" [] $ lst x ~> lst x ~> lst x), 276 | ("snoc", forall "x" [] $ lst x ~> x ~> lst x), 277 | ("len", forall "x" [] $ lst x ~> num), 278 | ("nlen", simply $ num ~> num), 279 | ("countf",forall "xy" [con y] $ (x ~> y) ~> lst x ~> num), 280 | ("count", forall "x" [con x] $ x ~> lst x ~> num), 281 | ("head", forall "x" [] $ lst x ~> x), 282 | ("last", forall "x" [] $ lst x ~> x), 283 | ("init", forall "x" [] $ lst x ~> lst x), 284 | ("tail", forall "x" [] $ lst x ~> lst x), 285 | ("fst", forall "xy" [] $ tup x y ~> x), 286 | ("snd", forall "xy" [] $ tup x y ~> y), 287 | ("indexC",forall "x" [con x] $ num ~> lst x ~> x), 288 | ("indexC2",forall "x" [con x] $ lst x ~> num ~> x), 289 | ("index", forall "x" [] $ num ~> lst x ~> x), 290 | ("index2",forall "x" [] $ lst x ~> num ~> x), 291 | ("take", forall "x" [] $ num ~> lst x ~> lst x), 292 | ("take2", forall "x" [] $ lst x ~> num ~> lst x), 293 | ("takew", forall "xy" [con y] $ (x ~> y) ~> lst x ~> lst x), 294 | ("drop", forall "x" [] $ num ~> lst x ~> lst x), 295 | ("drop2", forall "x" [] $ lst x ~> num ~> lst x), 296 | ("dropw", forall "xy" [con y] $ (x ~> y) ~> lst x ~> lst x), 297 | ("span", forall "xy" [con y] $ (x ~> y) ~> lst x ~> tup (lst x) (lst x)), 298 | ("rev", forall "x" [] $ lst x ~> lst x), 299 | ("heads", forall "x" [con x] $ x ~> lst x), 300 | ("tails", forall "x" [con x] $ x ~> lst x), 301 | ("nats", simply $ lst num), 302 | ("concat",forall "x" [] $ lst (lst x) ~> lst x), 303 | ("sum", simply $ lst num ~> num), 304 | ("prod", simply $ lst num ~> num), 305 | ("cartes",forall "x" [] $ lst (lst x) ~> lst (lst x)), 306 | ("elem", forall "x" [con x] $ lst x ~> x ~> num), 307 | ("elem'", forall "x" [con x] $ x ~> lst x ~> num), 308 | ("sort", forall "x" [con x] $ lst x ~> lst x), 309 | ("sorton",forall "xy" [con y] $ (x ~> y) ~> lst x ~> lst x), 310 | ("sortby",forall "xy" [con y] $ (x ~> x ~> y) ~> lst x ~> lst x), 311 | ("maxl", forall "x" [con x] $ lst x ~> x), 312 | ("minl", forall "x" [con x] $ lst x ~> x), 313 | ("diffl", forall "x" [con x] $ lst x ~> lst x ~> lst x), 314 | ("del", forall "x" [con x] $ x ~> lst x ~> lst x), 315 | ("nub", forall "x" [con x] $ lst x ~> lst x), 316 | ("nubon", forall "xy" [con y] $ (x ~> y) ~> lst x ~> lst x), 317 | ("nubby", forall "xy" [con y] $ (x ~> x ~> y) ~> lst x ~> lst x), 318 | ("nubw", forall "x" [con x] $ lst x ~> lst x), 319 | ("subs", forall "x" [con x] $ x ~> x ~> lst x ~> lst x), 320 | ("subs2", forall "x" [con x] $ lst x ~> lst x ~> lst x ~> lst x), 321 | ("group", forall "x" [con x] $ lst x ~> lst (lst x)), 322 | ("groupOn",forall "xy" [con y] $ (x ~> y) ~> lst x ~> lst (lst x)), 323 | ("groupBy",forall "xy" [con y] $ (x ~> x ~> y) ~> lst x ~> lst (lst x)), 324 | ("perms", forall "x" [] $ lst x ~> lst (lst x)), 325 | ("trsp", forall "x" [] $ lst (lst x) ~> lst (lst x)), 326 | ("trspw", forall "x" [] $ x ~> lst (lst x) ~> lst (lst x)), 327 | ("list2", forall "x" [] $ x ~> x ~> lst x), 328 | ("list3", forall "x" [] $ x ~> x ~> x ~> lst x), 329 | ("list4", forall "x" [] $ x ~> x ~> x ~> x ~> lst x), 330 | ("replic",forall "x" [] $ num ~> x ~> lst x), 331 | ("replif",forall "x" [] $ x ~> num ~> lst x), 332 | ("cuts", forall "x" [] $ lst num ~> lst x ~> lst (lst x)), 333 | ("cut", forall "x" [] $ num ~> lst x ~> lst (lst x)), 334 | ("cut2", forall "x" [] $ lst x ~> num ~> lst (lst x)), 335 | ("slice", forall "x" [] $ num ~> lst x ~> lst (lst x)), 336 | ("join", forall "x" [] $ lst x ~> lst (lst x) ~> lst x), 337 | ("join'", forall "x" [] $ x ~> lst (lst x) ~> lst x), 338 | ("powset",forall "x" [] $ lst x ~> lst (lst x)), 339 | ("powstN",forall "x" [] $ num ~> lst x ~> lst (lst x)), 340 | ("oelem", forall "x" [con x] $ lst x ~> x ~> num), 341 | ("oelem'",forall "x" [con x] $ x ~> lst x ~> num), 342 | ("slices",forall "x" [] $ lst x ~> lst (lst x)), 343 | ("clone", forall "x" [] $ num ~> lst x ~> lst x), 344 | ("clone'",forall "x" [] $ lst x ~> num ~> lst x), 345 | ("clones",forall "x" [] $ lst num ~> lst x ~> lst x), 346 | ("cycle", forall "x" [] $ lst x ~> lst x), 347 | ("cumsum",simply $ lst num ~> lst num), 348 | ("cumcat",forall "x" [] $ lst (lst x) ~> lst (lst x)), 349 | ("rangeN",simply $ num ~> num ~> lst num), 350 | ("rangeC",simply $ chr ~> chr ~> lst chr), 351 | ("same", forall "x" [con x] $ lst x ~> num), 352 | ("single",forall "x" [] $ lst x ~> num), 353 | ("rangeL",simply $ lst num ~> lst num), 354 | ("rangeS",simply $ lst chr ~> lst chr), 355 | ("joinE", forall "x" [] $ lst x ~> lst x ~> lst x), 356 | ("rotate",forall "x" [] $ num ~> lst x ~> lst x), 357 | ("rotatf",forall "x" [] $ lst x ~> num ~> lst x), 358 | ("prep0", forall "x" [] $ lst x ~> lst x), 359 | ("doubL", forall "x" [] $ lst x ~> lst x), 360 | ("halfL", forall "x" [] $ lst x ~> lst (lst x)), 361 | ("aptp", forall "xyz" [] $ (x ~> y ~> z) ~> tup x y ~> z), 362 | ("apftp", forall "xyz" [] $ (x ~> y ~> z) ~> tup y x ~> z), 363 | ("scltp", forall "xyz" [] $ (x ~> y ~> z) ~> tup x y ~> tup z y), 364 | ("scrtp", forall "xyz" [] $ (x ~> y ~> z) ~> tup x y ~> tup x z), 365 | ("maptp", forall "xy" [] $ (x ~> y) ~> tup x x ~> tup y y), 366 | ("lmaptp",forall "xyz" [] $ (x ~> z) ~> tup x y ~> tup z y), 367 | ("rmaptp",forall "xyz" [] $ (y ~> z) ~> tup x y ~> tup x z), 368 | ("adiags",forall "x" [] $ lst (lst x) ~> lst (lst x)), 369 | ("lrange",simply $ num ~> lst num), 370 | ("srange",simply $ num ~> lst num), 371 | ("ixes", forall "x" [] $ lst x ~> lst num), 372 | ("rvixes",forall "x" [] $ lst x ~> lst num), 373 | ("cpow", forall "x" [] $ num ~> lst x ~> lst (lst x)), 374 | ("cpow'", forall "x" [] $ lst x ~> num ~> lst (lst x)), 375 | ("cpowN", simply $ num ~> num ~> lst (lst num)), 376 | ("count2",forall "xy" [con y] $ (x ~> x ~> y) ~> lst x ~> num), 377 | ("unzip", forall "xy" [] $ lst (tup x y) ~> tup (lst x) (lst y)), 378 | ("split", forall "x" [con x] $ x ~> lst x ~> lst (lst x)), 379 | ("split'",forall "x" [con x] $ lst x ~> x ~> lst (lst x)), 380 | ("splitL",forall "x" [con x] $ lst x ~> lst x ~> lst (lst x)), 381 | ("joinV", forall "x" [] $ x ~> lst x ~> lst x), 382 | ("replen",forall "x" [] $ lst x ~> num ~> lst x), 383 | ("repln'",forall "x" [] $ num ~> lst x ~> lst x), 384 | ("isect", forall "x" [con x] $ lst x ~> lst x ~> lst x), 385 | ("mean", simply $ lst num ~> num), 386 | ("count'",forall "x" [con x] $ lst x ~> x ~> num), 387 | ("cart2", forall "x" [] $ lst x ~> lst x ~> lst (lst x)), 388 | ("ccons", forall "x" [] $ lst x ~> lst (lst x) ~> lst (lst x)), 389 | ("csnoc", forall "x" [] $ lst (lst x) ~> lst x ~> lst (lst x)), 390 | ("union", forall "x" [con x] $ lst x ~> lst x ~> lst x), 391 | ("ucons", forall "x" [con x] $ x ~> lst x ~> lst x), 392 | ("usnoc", forall "x" [con x] $ lst x ~> x ~> lst x), 393 | ("subset",forall "x" [con x] $ lst x ~> lst x ~> num), 394 | ("gaps", forall "x" [] $ num ~> lst x ~> lst x), 395 | ("gaps2", forall "x" [] $ lst x ~> num ~> lst x), 396 | ("gapsL", forall "x" [] $ lst num ~> lst x ~> lst x), 397 | ("chrsum",simply $ lst chr ~> num), 398 | ("nubwN", forall "x" [con x] $ num ~> lst x ~> lst x), 399 | ("merge", forall "x" [con x] $ lst (lst x) ~> lst x), 400 | ("cutL", forall "xy" [] $ lst (lst x) ~> lst y ~> lst (lst y)), 401 | ("ixsof", forall "x" [con x] $ x ~> lst x ~> lst num), 402 | ("ixsof2",forall "x" [con x] $ lst x ~> x ~> lst num), 403 | ("idx2d", forall "x" [] $ tup num num ~> lst (lst x) ~> x), 404 | ("idx2d2",forall "x" [] $ lst (lst x) ~> tup num num ~> x), 405 | 406 | -- Higher order functions 407 | ("map", forall "xy" [] $ (x ~> y) ~> (lst x ~> lst y)), 408 | ("mapr", forall "xy" [] $ lst (x ~> y) ~> x ~> lst y), 409 | ("zip", forall "xyz" [] $ (x ~> y ~> z) ~> (lst x ~> lst y ~> lst z)), 410 | ("fixp", forall "x" [con x] $ (x ~> x) ~> x ~> x), 411 | ("fixpL", forall "x" [con x] $ (x ~> lst x) ~> x ~> lst x), 412 | ("filter",forall "xy" [con y] $ (x ~> y) ~> lst x ~> lst x), 413 | ("select",forall "xy" [con x] $ lst x ~> lst y ~> lst y), 414 | ("foldl", forall "xy" [] $ (y ~> x ~> y) ~> y ~> lst x ~> y), 415 | ("foldl1",forall "x" [] $ (x ~> x ~> x) ~> lst x ~> x), 416 | ("foldr", forall "xy" [] $ (x ~> y ~> y) ~> y ~> lst x ~> y), 417 | ("foldr1",forall "x" [] $ (x ~> x ~> x) ~> lst x ~> x), 418 | ("scanl", forall "xy" [] $ (y ~> x ~> y) ~> y ~> lst x ~> lst y), 419 | ("scanl1",forall "x" [] $ (x ~> x ~> x) ~> lst x ~> lst x), 420 | ("scanr", forall "xy" [] $ (x ~> y ~> y) ~> y ~> lst x ~> lst y), 421 | ("scanr1",forall "x" [] $ (x ~> x ~> x) ~> lst x ~> lst x), 422 | ("list", forall "xy" [] $ y ~> (x ~> lst x ~> y) ~> lst x ~> y), 423 | ("listN", forall "xy" [] $ (x ~> lst x ~> y) ~> lst x ~> y), 424 | ("listF", forall "xy" [] $ y ~> ((lst x ~> y) ~> (x ~> lst x ~> y)) ~> lst x ~> y), 425 | ("listNF",forall "xy" [] $ ((lst x ~> y) ~> (x ~> lst x ~> y)) ~> lst x ~> y), 426 | ("iter", forall "x" [] $ (x ~> x) ~> x ~> lst x), 427 | ("iterL", forall "x" [] $ (x ~> lst x) ~> lst x ~> lst x), 428 | ("iterP", forall "x" [] $ (lst x ~> x) ~> lst x ~> lst x), 429 | ("iter2", forall "xy" [] $ (x ~> tup x y) ~> x ~> lst y), 430 | ("rep", forall "x" [] $ x ~> lst x), 431 | ("zip'", forall "x" [] $ (x ~> x ~> x) ~> lst x ~> lst x ~> lst x), 432 | ("cmap", forall "xy" [] $ (x ~> lst y) ~> lst x ~> lst y), 433 | ("smap", forall "x" [] $ (x ~> num) ~> lst x ~> num), 434 | ("cmapr", forall "xy" [] $ lst (x ~> lst y) ~> x ~> lst y), 435 | ("smapr", forall "x" [] $ lst (x ~> num) ~> x ~> num), 436 | ("table", forall "xyz" [] $ (x ~> y ~> z) ~> lst x ~> lst y ~> lst (lst z)), 437 | ("rmap", forall "xyz" [] $ (x ~> y ~> z) ~> x ~> lst y ~> lst z), 438 | ("lmap", forall "xyz" [] $ (x ~> y ~> z) ~> lst x ~> y ~> lst z), 439 | ("mapacL",forall "xyz" [] $ (x ~> y ~> x) ~> (x ~> y ~> z) ~> x ~> lst y ~> lst z), 440 | ("mapacR",forall "xyz" [] $ (y ~> x ~> x) ~> (y ~> x ~> z) ~> x ~> lst y ~> lst z), 441 | ("mapad2",forall "xy" [] $ (x ~> x ~> y) ~> lst x ~> lst y), 442 | ("mapad3",forall "xy" [] $ (x ~> x ~> x ~> y) ~> lst x ~> lst y), 443 | ("mix", forall "xyz" [] $ (x ~> y ~> z) ~> lst x ~> lst y ~> lst z), 444 | ("twice", forall "x" [] $ (x ~> x) ~> (x ~> x)), 445 | ("find", forall "xy" [con y] $ (x ~> y) ~> lst x ~> x), 446 | ("findN", forall "x" [con x] $ (num ~> x) ~> num ~> num), 447 | ("until", forall "xy" [con y] $ (x ~> y) ~> (x ~> x) ~> (x ~> x)), 448 | ("decorM",forall "xyzu" [] $ ((tup x y ~> z) ~> lst (tup x y) ~> lst (lst (tup x u))) ~> (x ~> y ~> z) ~> lst x ~> lst y ~> lst (lst u)), 449 | ("decorL",forall "xyzu" [] $ ((tup x y ~> z) ~> lst (tup x y) ~> lst (tup x u)) ~> (x ~> y ~> z) ~> lst x ~> lst y ~> lst u), 450 | ("decorV",forall "xyzu" [] $ ((tup x y ~> z) ~> lst (tup x y) ~> tup x u) ~> (x ~> y ~> z) ~> lst x ~> lst y ~> u), 451 | ("decorN",forall "xyzu" [] $ ((tup x y ~> z) ~> lst (tup x y) ~> u) ~> (x ~> y ~> z) ~> lst x ~> lst y ~> u), 452 | ("minby", forall "xy" [con y] $ (x ~> x ~> y) ~> x ~> x ~> x), 453 | ("maxby", forall "xy" [con y] $ (x ~> x ~> y) ~> x ~> x ~> x), 454 | ("minon", forall "xy" [con y] $ (x ~> y) ~> x ~> x ~> x), 455 | ("maxon", forall "xy" [con y] $ (x ~> y) ~> x ~> x ~> x), 456 | ("minlby",forall "xy" [con y] $ (x ~> x ~> y) ~> lst x ~> x), 457 | ("maxlby",forall "xy" [con y] $ (x ~> x ~> y) ~> lst x ~> x), 458 | ("minlon",forall "xy" [con y] $ (x ~> y) ~> lst x ~> x), 459 | ("maxlon",forall "xy" [con y] $ (x ~> y) ~> lst x ~> x), 460 | ("toadjM",forall "xy" [] $ ((tup x x ~> y) ~> lst (tup x x) ~> lst (lst (tup x x))) ~> (x ~> x ~> y) ~> lst x ~> lst (lst x)), 461 | ("toadjL",forall "xy" [] $ ((tup x x ~> y) ~> lst (tup x x) ~> lst (tup x x)) ~> (x ~> x ~> y) ~> lst x ~> lst x), 462 | ("toadjV",forall "xy" [] $ ((tup x x ~> y) ~> lst (tup x x) ~> tup x x) ~> (x ~> x ~> y) ~> lst x ~> x), 463 | ("toadjN",forall "xyz" [] $ ((tup x x ~> y) ~> lst (tup x x) ~> z) ~> (x ~> x ~> y) ~> lst x ~> z), 464 | ("sameon",forall "xy" [con y] $ (x ~> y) ~> lst x ~> num), 465 | ("sameby",forall "xy" [con y] $ (x ~> x ~> y) ~> lst x ~> num), 466 | ("keyon", forall "xy" [con y] $ (x ~> y) ~> lst x ~> lst (lst x)), 467 | ("keyby", forall "xy" [con y] $ (x ~> x ~> y) ~> lst x ~> lst (lst x)), 468 | ("onixes",forall "xy" [] $ ((num ~> x) ~> lst num ~> y) ~> lst x ~> y), 469 | ("where", forall "xy" [con y] $ (x ~> y) ~> lst x ~> lst num), 470 | ("where2",forall "xy" [con y] $ (x ~> x ~> y) ~> lst x ~> lst num), 471 | 472 | -- Combinators 473 | ("hook", forall "xyz" [] $ (x ~> y ~> z) ~> (x ~> y) ~> x ~> z), 474 | ("hookf", forall "xyz" [] $ (x ~> y ~> z) ~> (y ~> x) ~> y ~> z), 475 | ("bhook", forall "xyzu" [] $ (x ~> y ~> z) ~> (x ~> u ~> y) ~> x ~> u ~> z), 476 | ("bhookf",forall "xyzu" [] $ (x ~> y ~> z) ~> (u ~> y ~> x) ~> u ~> y ~> z), 477 | ("const", forall "xy" [] $ x ~> y ~> x), 478 | ("id", forall "x" [] $ x ~> x), 479 | ("fix", forall "x" [] $ (x ~> x) ~> x), 480 | ("flip", forall "xyz" [] $ (x ~> y ~> z) ~> (y ~> x ~> z)), 481 | ("com4", forall "xyzuvw" [] $ (v ~> w) ~> (x ~> y ~> z ~> u ~> v) ~> (x ~> y ~> z ~> u ~> w)), 482 | ("com3", forall "xyzuv" [] $ (u ~> v) ~> (x ~> y ~> z ~> u) ~> (x ~> y ~> z ~> v)), 483 | ("com2", forall "xyzu" [] $ (z ~> u) ~> (x ~> y ~> z) ~> (x ~> y ~> u)), 484 | ("com", forall "xyz" [] $ (y ~> z) ~> (x ~> y) ~> (x ~> z)), 485 | ("app", forall "xy" [] $ (x ~> y) ~> x ~> y), 486 | ("fork", forall "xyzu" [] $ (x ~> y ~> z) ~> (u ~> x) ~> (u ~> y) ~> u ~> z), 487 | ("fork2", forall "xyzuv" [] $ (x ~> y ~> z) ~> (u ~> v ~> x) ~> (u ~> v ~> y) ~> u ~> v ~> z), 488 | ("argdup",forall "xy" [] $ (x ~> x ~> y) ~> x ~> y), 489 | ("combin",forall "xyz" [] $ (y ~> y ~> z) ~> (x ~> y) ~> (x ~> x ~> z)), 490 | ("branch",forall "xyzuv" [] $ (x ~> y ~> z) ~> (u ~> x) ~> (v ~> y) ~> (u ~> v ~> z)), 491 | ("comf", forall "xyzu" [] $ (x ~> y ~> z) ~> (u ~> y) ~> (x ~> u ~> z)), 492 | ("comf2", forall "xyzuv" [] $ (x ~> y ~> z) ~> (u ~> v ~> y) ~> (x ~> u ~> v ~> z)), 493 | ("comf3", forall "xyzuvw" [] $ (x ~> y ~> z) ~> (u ~> v ~> w ~> y) ~> (x ~> u ~> v ~> w ~> z)), 494 | ("comf4", forall "xyzuvwt" [] $ (x ~> y ~> z) ~> (u ~> v ~> w ~> t ~> y) ~> (x ~> u ~> v ~> w ~> t ~> z)), 495 | ("flipap",forall "xyz" [] $ y ~> (x ~> y ~> z) ~> (x ~> z)), 496 | 497 | -- Boolean functions and comparisons 498 | ("lt", forall "x" [con x] $ x ~> x ~> num), 499 | ("gt", forall "x" [con x] $ x ~> x ~> num), 500 | ("le", forall "x" [con x] $ x ~> x ~> num), 501 | ("ge", forall "x" [con x] $ x ~> x ~> num), 502 | ("eq", forall "x" [con x] $ x ~> x ~> num), 503 | ("neq", forall "x" [con x] $ x ~> x ~> num), 504 | ("if", forall "xy" [con x] $ y ~> y ~> x ~> y), 505 | ("if2", forall "xy" [con x] $ (x ~> y) ~> y ~> x ~> y), 506 | ("fif", forall "xyz" [con x] $ (z ~> y) ~> (z ~> y) ~> (z ~> x) ~> z ~> y), 507 | ("not", forall "x" [con x] $ x ~> num), 508 | ("fnot", forall "xy" [con y] $ (x ~> y) ~> (x ~> num)), 509 | ("or", forall "x" [con x] $ x ~> x ~> x), 510 | ("or'", forall "x" [con x, con y] $ x ~> y ~> num), 511 | ("and", forall "x" [con x] $ x ~> x ~> x), 512 | ("and'", forall "x" [con x, con y] $ x ~> y ~> num), 513 | ("max", forall "x" [con x] $ x ~> x ~> x), 514 | ("min", forall "x" [con x] $ x ~> x ~> x), 515 | ("any", forall "xy" [con y] $ (x ~> y) ~> lst x ~> num), 516 | ("all", forall "xy" [con y] $ (x ~> y) ~> lst x ~> num), 517 | ("subl", forall "x" [con x] $ lst x ~> lst x ~> num), 518 | ("congr", forall "x" [con x] $ x ~> x ~> num), 519 | ("simil", forall "x" [con x] $ x ~> x ~> num), 520 | ("any2", forall "xy"[con y] $ (x ~> x ~> y) ~> lst x ~> num), 521 | ("all2", forall "xy"[con y] $ (x ~> x ~> y) ~> lst x ~> num), 522 | 523 | -- Chars and strings 524 | ("chr", simply $ num ~> chr), 525 | ("ord", simply $ chr ~> num), 526 | ("predC", simply $ chr ~> chr), 527 | ("succC", simply $ chr ~> chr), 528 | ("show", forall "x" [con x] $ x ~> lst chr), 529 | ("read", forall "x" [con x] $ lst chr ~> x), 530 | ("words", simply $ lst chr ~> lst (lst chr)), 531 | ("unwords", simply $ lst (lst chr) ~> lst chr), 532 | ("uwshow",forall "x" [con x] $ lst x ~> lst chr), 533 | ("uwpshw",forall "xy" [con x,con y] $ tup x y ~> lst chr), 534 | ("lines", simply $ lst chr ~> lst (lst chr)), 535 | ("unlines", simply $ lst (lst chr) ~> lst chr), 536 | ("ulshow",forall "x" [con x] $ lst x ~> lst chr), 537 | ("ulpshw",forall "xy" [con x,con y] $ tup x y ~> lst chr), 538 | ("isanum",simply $ chr ~> num), 539 | ("isalph",simply $ chr ~> num), 540 | ("isuppr",simply $ chr ~> num), 541 | ("islowr",simply $ chr ~> num), 542 | ("isdigt",simply $ chr ~> num), 543 | ("touppr",simply $ chr ~> chr), 544 | ("tolowr",simply $ chr ~> chr), 545 | ("swcase",simply $ chr ~> chr), 546 | 547 | -- Type conversions 548 | ("n2i", simply $ num ~> num), 549 | ("c2i", simply $ chr ~> num), 550 | ("s2i", simply $ lst chr ~> num) 551 | ] 552 | -------------------------------------------------------------------------------- /Defs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, FlexibleInstances, FlexibleContexts, BangPatterns #-} 2 | 3 | module Defs where 4 | -- Built-in functions 5 | 6 | import Data.Function (fix) 7 | import qualified Data.Char as C 8 | import Data.Char (chr,ord) 9 | import Data.List 10 | import qualified Data.Set as S (member, insert, singleton) 11 | import Data.Ord (comparing) 12 | import Data.Bits ((.&.), (.|.)) 13 | import Data.Ratio ((%), numerator, denominator) 14 | 15 | import Numeric (showFFloat) 16 | 17 | -- Type of numeric values: integer fractions and Doubles 18 | -- 1:%0 is infinity 19 | -- -1:%0 is negative infinity 20 | -- 0:%0 is Any 21 | data TNum = !Integer :% !Integer 22 | | TDbl !Double 23 | 24 | -- Convert to Double 25 | doublify :: TNum -> Double 26 | doublify (p :% q) = fromInteger p / fromInteger q 27 | doublify (TDbl a) = a 28 | 29 | instance Eq TNum where 30 | p :% 0 == q :% 0 = p == q 31 | p :% q == r :% s = p*s == q*r 32 | x == y = doublify x == doublify y 33 | 34 | instance Ord TNum where 35 | compare (p :% 0) (r :% 0) = compare p r 36 | compare (p :% q) (r :% s) = compare (p*s) (q*r) 37 | compare x y = compare (doublify x) (doublify y) 38 | 39 | boolToNum :: Bool -> TNum 40 | boolToNum True = 1 41 | boolToNum False = 0 42 | 43 | -- Instances for TNum 44 | instance Show TNum where 45 | show (p :% 1) = show p 46 | show (1 :% 0) = "Inf" 47 | show (0 :% 0) = "Any" 48 | show ((-1) :% 0) = "-Inf" 49 | show (p :% q) = show p ++ "/" ++ show q 50 | show (TDbl d) = showFFloat Nothing d "" 51 | 52 | instance Read TNum where 53 | readsPrec n str 54 | | p@(_:_) <- tryInt, 55 | x@(_:_) <- [(k, q) | (k, '/':rest) <- p, q <- readsPrec n rest] 56 | = [(cancel $ k :% m, rest2) | (k, (m, rest2)) <- x] 57 | | p@(_:_) <- tryInt = [(k :% 1, rest) | (k, rest) <- p] 58 | | p@(_:_) <- tryDbl = [(TDbl k, rest) | (k, rest) <- p] 59 | | 'I':'n':'f':rest <- str = [(1 :% 0, rest)] 60 | | 'A':'n':'y':rest <- str = [(0 :% 0, rest)] 61 | | '-':'I':'n':'f':rest <- str = [((-1) :% 0, rest)] 62 | | otherwise = [] 63 | where tryInt = readsPrec n str :: [(Integer, String)] 64 | tryDbl = readsPrec n str :: [(Double, String)] 65 | 66 | -- Simplify a fraction 67 | cancel :: TNum -> TNum 68 | cancel (p :% 0) = signum p :% 0 69 | cancel (p :% q) 70 | | k <- signum q * p, 71 | n <- abs q, 72 | r <- gcd k n 73 | = div k r :% div n r 74 | cancel a = a 75 | 76 | -- Create a binary numeric operator 77 | -- operate f (!) applies f to fractions and (!) to Doubles, 78 | -- converting fractions to Doubles when necessary 79 | operate :: (Integer -> Integer -> Integer -> Integer -> (Integer, Integer)) -> (Double -> Double -> TNum) -> TNum -> TNum -> TNum 80 | operate f _ (p :% q) (r :% s) | (x, y) <- f p q r s = cancel $ x :% y 81 | operate _ (!) a b = doublify a ! doublify b 82 | 83 | instance Num TNum where 84 | (+) = operate (\p q r s -> (p*s + r*q, q*s)) ((TDbl .) . (+)) 85 | 86 | (-) = operate (\p q r s -> (p*s - r*q, q*s)) ((TDbl .) . (-)) 87 | 88 | (*) = operate (\p q r s -> (p*r, q*s)) ((TDbl .) . (*)) 89 | 90 | abs (p :% q) = abs p :% q 91 | abs (TDbl a) = TDbl $ abs a 92 | 93 | signum (p :% _) = signum p :% 1 94 | signum (TDbl a) = round (signum a) :% 1 95 | 96 | negate (p :% q) = negate p :% q 97 | negate (TDbl a) = TDbl $ negate a 98 | 99 | fromInteger = (:% 1) 100 | 101 | instance Real TNum where 102 | toRational (p :% q) = p % q 103 | toRational (TDbl a) = toRational a 104 | 105 | instance Enum TNum where 106 | toEnum n = toEnum n :% 1 107 | 108 | fromEnum (p :% q) = fromEnum $ p % q 109 | fromEnum (TDbl n) = fromEnum n 110 | 111 | succ = (+1) 112 | pred = (-1+) 113 | 114 | enumFrom = iterate succ 115 | enumFromThen a b = iterate (+(b-a)) a 116 | enumFromTo a c = case compare a c of 117 | GT -> [] 118 | EQ -> [a] 119 | LT -> takeWhile (<= c) $ iterate succ a 120 | enumFromThenTo a b c = case (compare a c, compare a b) of 121 | (GT, GT) -> takeWhile (>= c) $ iterate (+(b-a)) a 122 | (GT, _) -> [] 123 | (EQ, GT) -> [a] 124 | (EQ, EQ) -> repeat a 125 | (EQ, LT) -> [a] 126 | (LT, GT) -> [] 127 | (LT, EQ) -> repeat a 128 | (LT, LT) -> takeWhile (<= c) $ iterate (+(b-a)) a 129 | 130 | instance Integral TNum where 131 | toInteger (p :% q) = div p q 132 | toInteger (TDbl d) = truncate d 133 | 134 | quotRem a@(_ :% _) b@(_ :% _) 135 | | d@(p :% q) <- a / b, 136 | k <- div p q :% 1 137 | = if q == 0 138 | then (d, a * signum d) 139 | else (k, a - b*k) 140 | quotRem a b 141 | | x <- doublify a, 142 | y <- doublify b, 143 | r <- truncate $ x / y 144 | = (r :% 1, TDbl $ x - y * fromInteger r) 145 | 146 | instance Fractional TNum where 147 | fromRational r = numerator r :% denominator r 148 | 149 | (/) = operate 150 | (\p q r s -> (p*s, q*r)) 151 | (\x y -> if y == 0 152 | then round (signum x) :% 0 153 | else TDbl $ x/y) 154 | 155 | -- Lift a numeric function to TNums 156 | -- The extra arguments are results for Inf and -Inf 157 | numeric :: (Double -> Double) -> TNum -> TNum -> (TNum -> TNum) 158 | numeric f pinf ninf = g 159 | where g (1 :% 0) = pinf 160 | g (0 :% 0) = 0 :% 0 161 | g ((-1) :% 0) = ninf 162 | g x = TDbl $ f $ doublify x 163 | 164 | instance Floating TNum where 165 | pi = TDbl pi 166 | 167 | exp = numeric exp (1 :% 0) 0 168 | log = numeric log (1 :% 0) 0 169 | sqrt = numeric sqrt (1 :% 0) ((-1) :% 0) 170 | 171 | sin = numeric sin 0 0 172 | cos = numeric cos 0 0 173 | tan = numeric tan 0 0 174 | 175 | asin = numeric asin 0 0 176 | acos = numeric acos 0 0 177 | atan = numeric atan (pi/2) (-pi/2) 178 | 179 | sinh = numeric sinh (1 :% 0) ((-1) :% 0) 180 | cosh = numeric cosh (1 :% 0) (1 :% 0) 181 | tanh = numeric tanh 1 (-1) 182 | 183 | asinh = numeric asinh (1 :% 0) ((-1) :% 0) 184 | acosh = numeric acosh (1 :% 0) 0 185 | atanh = numeric atanh 0 0 186 | 187 | instance RealFrac TNum where 188 | properFraction a@(_ :% 0) = (0, a) 189 | properFraction (p :% q) | r <- quot p q = (fromInteger r, (p - r) :% q) 190 | properFraction (TDbl a) | (n, r) <- properFraction a = (n, TDbl r) 191 | 192 | -- Class of all Husk types (used for defaulting) 193 | 194 | class Husky a where 195 | defVal :: a 196 | 197 | instance Husky TNum where 198 | defVal = 0 199 | 200 | instance Husky Char where 201 | defVal = ' ' 202 | 203 | instance (Husky a) => Husky [a] where 204 | defVal = [] 205 | 206 | instance (Husky a, Husky b) => Husky (a,b) where 207 | defVal = (defVal, defVal) 208 | 209 | instance (Husky b) => Husky (a -> b) where 210 | defVal = const defVal 211 | 212 | -- String conversion 213 | class ToString a where 214 | toString :: a -> String 215 | 216 | instance {-# OVERLAPPING #-} ToString String where 217 | toString = id 218 | 219 | instance {-# OVERLAPPING #-} ToString [String] where 220 | toString = unlines 221 | 222 | instance {-# OVERLAPPING #-} ToString [[String]] where 223 | toString = unlines.map unwords 224 | 225 | instance Concrete a => ToString a where 226 | toString = show 227 | 228 | 229 | -- Class of concrete values 230 | class (Husky a, Show a, Read a, Eq a, Ord a, ToString a) => Concrete a where 231 | isTruthy :: a -> Bool 232 | toTruthy :: a -> TNum 233 | func_false :: a 234 | func_false = defVal 235 | func_true :: a 236 | func_lt :: a -> a -> TNum 237 | func_gt :: a -> a -> TNum 238 | func_le :: a -> a -> TNum 239 | func_ge :: a -> a -> TNum 240 | func_neq :: a -> a -> TNum 241 | func_congr :: a -> a -> TNum 242 | func_simil :: a -> a -> TNum 243 | 244 | func_maxval :: a 245 | func_minval :: a 246 | 247 | func_heads :: a -> [a] 248 | func_tails :: a -> [a] 249 | 250 | func_eq :: a -> a -> TNum 251 | func_eq x y = boolToNum $ x == y 252 | 253 | func_or :: a -> a -> a 254 | func_or y x = if isTruthy x then x else y 255 | 256 | func_and :: a -> a -> a 257 | func_and y x = if isTruthy x then y else x 258 | 259 | func_read :: [Char] -> a 260 | func_read x | ((val, _):_) <- reads x = val 261 | | otherwise = defVal 262 | 263 | func_or' :: (Concrete a, Concrete b) => a -> b -> TNum 264 | func_or' x y = func_or (toTruthy x) (toTruthy y) 265 | 266 | func_and' :: (Concrete a, Concrete b) => a -> b -> TNum 267 | func_and' x y = func_and (toTruthy x) (toTruthy y) 268 | 269 | instance Concrete TNum where 270 | isTruthy = (/= 0) 271 | toTruthy (TDbl d) = roundAway d :% 1 272 | toTruthy n = n 273 | func_true = 1 274 | func_lt y x = max 0 $ toTruthy (y-x) 275 | func_gt y x = max 0 $ toTruthy (x-y) 276 | func_le y x | x > y = 0 277 | | otherwise = toTruthy $ y-x+1 278 | func_ge y x | x < y = 0 279 | | otherwise = toTruthy $ x-y+1 280 | func_neq y x = abs $ toTruthy (x-y) 281 | 282 | func_maxval = 1 :% 0 283 | func_minval = (-1) :% 0 284 | 285 | func_congr 0 0 = 1 286 | func_congr 0 _ = 0 287 | func_congr _ 0 = 0 288 | func_congr _ _ = 1 289 | 290 | func_simil x y | abs (x-y) <= 1 = 1 291 | | otherwise = 0 292 | 293 | func_heads x | x >= 0 = [1 .. x] 294 | | otherwise = [x .. -1] 295 | func_tails x | x >= 0 = [x, x-1 .. 1] 296 | | otherwise = [-1, -2 .. x] 297 | 298 | instance Concrete Char where 299 | isTruthy = not . C.isSpace 300 | toTruthy = boolToNum.isTruthy 301 | func_true = '!' 302 | func_lt y x = fromIntegral $ max 0 (ord y - ord x) 303 | func_gt y x = fromIntegral $ max 0 (ord x - ord y) 304 | func_le y x = fromIntegral $ max 0 (ord y - ord x + 1) 305 | func_ge y x = fromIntegral $ max 0 (ord x - ord y + 1) 306 | func_neq y x = abs.fromIntegral $ (ord x)-(ord y) 307 | 308 | func_maxval = maxBound 309 | func_minval = minBound 310 | 311 | func_congr x y | isTruthy x == isTruthy y = 1 312 | | otherwise = 0 313 | 314 | func_simil x y | x==y || x == succ y || y == succ x = 1 315 | | otherwise = 0 316 | 317 | func_heads x = ['\0'..x] 318 | func_tails x = [x, pred x..'\0'] 319 | 320 | instance Concrete a => Concrete [a] where 321 | isTruthy = (/= []) 322 | toTruthy = genericLength 323 | func_true = [func_true] 324 | func_lt = go 1 325 | where go n (_:_) [] = n 326 | go n (y:ys) (x:xs) | x < y = n 327 | | x > y = 0 328 | | otherwise = go (n+1) ys xs 329 | go _ _ _ = 0 330 | func_gt x y = func_lt y x 331 | func_le = go 1 332 | where go n _ [] = n 333 | go n (y:ys) (x:xs) | x < y = n 334 | | x > y = 0 335 | | otherwise = go (n+1) ys xs 336 | go _ _ _ = 0 337 | func_ge x y = func_le y x 338 | func_neq = go 1 339 | where go n [] [] = 0 340 | go n (x:xs) (y:ys) | x /= y = n 341 | | otherwise = go (n+1) xs ys 342 | go n _ _ = n 343 | 344 | func_maxval = repeat func_maxval 345 | func_minval = [] 346 | 347 | func_congr [] [] = 1 348 | func_congr [] _ = 0 349 | func_congr _ [] = 0 350 | func_congr (x:xs) (y:ys) = if func_congr x y == 0 then 0 else func_congr xs ys 351 | 352 | func_simil (x:xs) (y:ys) = func_simil xs ys 353 | func_simil [] [] = 1 354 | func_simil _ _ = 0 355 | 356 | func_heads=tail.inits 357 | func_tails=init.tails 358 | 359 | instance (Concrete a, Concrete b) => Concrete (a, b) where 360 | isTruthy (x, y) = isTruthy x && isTruthy y 361 | toTruthy (x, y) = toTruthy x * toTruthy y 362 | func_true = (func_true, func_true) 363 | func_lt (x, y) (x', y') = if x == x' then func_lt y y' else func_lt x x' 364 | func_gt (x, y) (x', y') = if x == x' then func_gt y y' else func_gt x x' 365 | func_le (x, y) (x', y') = if x > x' then func_lt y y' else func_le x x' 366 | func_ge (x, y) (x', y') = if x < x' then func_gt y y' else func_ge x x' 367 | func_neq (x, y) (x', y') = if x == x' then func_neq y y' else func_neq x x' 368 | 369 | func_maxval = (func_maxval, func_maxval) 370 | func_minval = (func_minval, func_minval) 371 | 372 | func_congr (a,b) (c,d) = if func_congr a c + func_congr b d == 2 then 1 else 0 373 | func_simil (a,b) (c,d) = if func_simil a c + func_simil b d == 2 then 1 else 0 374 | 375 | func_heads (a,b) = [(c,d)|c<-func_heads a,d<-func_heads b] 376 | func_tails (a,b) = [(c,d)|c<-func_tails a,d<-func_tails b] 377 | 378 | roundAway :: Double -> Integer 379 | roundAway d = if d<0 then floor d else ceiling d 380 | 381 | --Primes (quite efficient implementation, but not the most efficient) 382 | primes_list = 2 : oddprimes 383 | where 384 | oddprimes = sieve [3,5..] 9 oddprimes 385 | sieve (x:xs) q ps@ ~(p:t) 386 | | x < q = x : sieve xs q ps 387 | | otherwise = sieve (xs `minus` [q, q+2*p..]) (head t^2) t 388 | minus (x:xs) (y:ys) = case (compare x y) of 389 | LT -> x : minus xs (y:ys) 390 | EQ -> minus xs ys 391 | GT -> minus (x:xs) ys 392 | minus xs _ = xs 393 | 394 | 395 | -- Built-in functions 396 | 397 | func_fix :: (a -> a) -> a 398 | func_fix = fix 399 | 400 | func_fixp :: Concrete a => (a -> a) -> a -> a 401 | func_fixp f a = go (S.singleton a) $ f a 402 | where go xs x | x `S.member` xs = x 403 | | otherwise = go (S.insert x xs) $ f x 404 | 405 | func_fixpL :: Concrete a => (a -> [a]) -> a -> [a] 406 | func_fixpL f a = cs 407 | where f' = concatMap f 408 | b = func_fixp (take 1 . f') [a] 409 | n = succ $ length $ takeWhile (/= b) $ tail $ iterate (take 1 . f') b 410 | f'' = foldr1 (.) $ replicate n f' 411 | cs = b ++ tail (f'' cs) 412 | 413 | func_app :: (a -> b) -> a -> b 414 | func_app = id 415 | 416 | func_com :: (b -> c) -> (a -> b) -> a -> c 417 | func_com = (.) 418 | 419 | func_com2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d 420 | func_com2 f g x = f . g x 421 | 422 | func_com3 :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e 423 | func_com3 f g x y = f . g x y 424 | 425 | func_com4 :: (e -> f) -> (a -> b -> c -> d -> e) -> a -> b -> c -> d -> f 426 | func_com4 f g x y z = f . g x y z 427 | 428 | func_add :: TNum -> TNum -> TNum 429 | func_add = (+) 430 | 431 | func_sub :: TNum -> TNum -> TNum 432 | func_sub b a = a - b 433 | 434 | func_mul :: TNum -> TNum -> TNum 435 | func_mul = (*) 436 | 437 | func_div :: TNum -> TNum -> TNum 438 | func_div b a = a / b 439 | 440 | func_idiv :: TNum -> TNum -> TNum 441 | func_idiv b a = a `div` b 442 | 443 | func_mod :: TNum -> TNum -> TNum 444 | func_mod b a = a `mod` b 445 | 446 | func_divds :: TNum -> TNum -> TNum 447 | func_divds b a = 448 | if func_mod b a == 0 449 | then if a == 0 450 | then 1 451 | else func_idiv b a 452 | else 0 453 | 454 | func_neg :: TNum -> TNum 455 | func_neg x = -x 456 | 457 | func_inv :: TNum -> TNum 458 | func_inv = recip 459 | 460 | -- Triangular numbers: sum of all numbers in [1..n] 461 | func_trian :: TNum -> TNum 462 | func_trian (p :% 1) = div (p*(p+1)) 2 :% 1 463 | func_trian r = r*(r+1)/2 464 | 465 | func_fact :: TNum -> TNum 466 | func_fact n = product [1..n] 467 | 468 | func_pure :: a -> [a] 469 | func_pure = (: []) 470 | 471 | func_cons :: a -> [a] -> [a] 472 | func_cons = (:) 473 | 474 | func_snoc :: [a] -> a -> [a] 475 | func_snoc x y = x ++ [y] 476 | 477 | func_cat :: [a] -> [a] -> [a] 478 | func_cat = (++) 479 | 480 | func_head :: (Husky a) => [a] -> a 481 | func_head [] = defVal 482 | func_head (x:_) = x 483 | 484 | func_last :: (Husky a) => [a] -> a 485 | func_last [] = defVal 486 | func_last xs = last xs 487 | 488 | func_tail :: [a] -> [a] 489 | func_tail [] = [] 490 | func_tail (_:xs) = xs 491 | 492 | func_init :: [a] -> [a] 493 | func_init [] = [] 494 | func_init xs = init xs 495 | 496 | func_pair :: a -> b -> (a, b) 497 | func_pair = (,) 498 | 499 | func_swap :: (a,b) -> (b,a) 500 | func_swap (x,y) = (y,x) 501 | 502 | func_fst :: (a,b) -> a 503 | func_fst = fst 504 | 505 | func_snd :: (a,b) -> b 506 | func_snd = snd 507 | 508 | func_map :: (a -> b) -> [a] -> [b] 509 | func_map = map 510 | 511 | func_mapr :: [(a -> b)] -> a -> [b] 512 | func_mapr fs a = [f a | f<-fs] 513 | 514 | func_zip :: (a -> b -> c) -> [a] -> [b] -> [c] 515 | func_zip = zipWith 516 | 517 | func_filter :: Concrete b => (a -> b) -> [a] -> [a] 518 | func_filter f = filter $ isTruthy . f 519 | 520 | func_select :: Concrete a => [a] -> [b] -> [b] 521 | func_select x y = [b | (a, b) <- zip x y, isTruthy a] 522 | 523 | func_scanl :: (b -> a -> b) -> b -> [a] -> [b] 524 | func_scanl = scanl 525 | 526 | func_scanl1 :: (a -> a -> a) -> [a] -> [a] 527 | func_scanl1 = scanl1 528 | 529 | func_scanr :: (a -> b -> b) -> b -> [a] -> [b] 530 | func_scanr = scanr 531 | 532 | func_scanr1 :: (a -> a -> a) -> [a] -> [a] 533 | func_scanr1 = scanr1 534 | 535 | func_len :: [a] -> TNum 536 | func_len = genericLength 537 | 538 | func_nlen :: TNum -> TNum 539 | func_nlen = genericLength.show 540 | 541 | func_countf :: Concrete b => (a -> b) -> [a] -> TNum 542 | func_countf c = genericLength . filter (isTruthy . c) 543 | 544 | func_count :: Concrete a => a -> [a] -> TNum 545 | func_count x = genericLength . filter (== x) 546 | 547 | func_count' :: Concrete a => [a] -> a -> TNum 548 | func_count' = flip func_count 549 | 550 | func_index :: (Husky a) => TNum -> [a] -> a 551 | func_index _ [] = defVal 552 | func_index i xs 553 | | (1 :% 0) <- i = last xs 554 | | (0 :% 0) <- i = defVal 555 | | ((-1) :% 0) <- i = head xs 556 | | toInteger i>0 = genericIndex (cycle xs) $ toInteger i-1 557 | | otherwise = genericIndex (cycle $ reverse xs) $ -toInteger i 558 | 559 | func_index2 :: (Husky a) => [a] -> TNum -> a 560 | func_index2 = flip func_index 561 | 562 | func_rev :: [a] -> [a] 563 | func_rev = reverse 564 | 565 | func_nats :: [TNum] 566 | func_nats = [1, 2 ..] 567 | 568 | func_sum :: [TNum] -> TNum 569 | func_sum = sum 570 | 571 | func_prod :: [TNum] -> TNum 572 | func_prod = product 573 | 574 | func_concat :: [[a]] -> [a] 575 | func_concat = concat 576 | 577 | func_cartes :: [[a]] -> [[a]] 578 | func_cartes [] = [[]] 579 | func_cartes (x:xs) = func_mix (:) x $ func_cartes xs 580 | 581 | func_mix :: (a -> b -> c) -> [a] -> [b] -> [c] 582 | func_mix f xs ys = concat $ func_adiags $ func_table f xs ys 583 | 584 | -- Lazy merges 585 | merge3 :: [a] -> [a] -> [a] -> [a] 586 | merge3 (x:xs) ys zs = x : next ys 587 | where next (b:bs) = b : next' zs 588 | where next' (c:cs) = c : merge3 xs bs cs 589 | next' [] = merge2 xs ys 590 | next [] = merge2 xs zs 591 | merge3 [] ys zs = merge2 ys zs 592 | 593 | merge2 :: [a] -> [a] -> [a] 594 | merge2 (x:xs) ys = x : next ys 595 | where next (y:ys) = y : merge2 xs ys 596 | next [] = xs 597 | merge2 [] ys = ys 598 | 599 | func_if :: Concrete a => b -> b -> a -> b 600 | func_if b c a = if isTruthy a then b else c 601 | 602 | func_if2 :: Concrete a => (a->b) -> b -> a -> b 603 | func_if2 g c a = if isTruthy a then g a else c 604 | 605 | func_fif :: Concrete a => (x->b) -> (x->b) -> (x->a) -> x -> b 606 | func_fif g h f x = if isTruthy (f x) then g x else h x 607 | 608 | func_not :: Concrete a => a -> TNum 609 | func_not a = if isTruthy a then 0 else 1 610 | 611 | func_fnot :: Concrete b => (a -> b) -> a -> TNum 612 | func_fnot f = func_not . f 613 | 614 | func_hook :: (a -> b -> c) -> (a -> b) -> a -> c 615 | func_hook x y z = x z (y z) 616 | 617 | func_hookf :: (a -> b -> c) -> (b -> a) -> b -> c 618 | func_hookf x y z = x (y z) z 619 | 620 | func_const :: a -> b -> a 621 | func_const x _ = x 622 | 623 | func_id :: a -> a 624 | func_id x = x 625 | 626 | func_flip :: (a -> b -> c) -> (b -> a -> c) 627 | func_flip = flip 628 | 629 | func_foldl :: (b -> a -> b) -> b -> [a] -> b 630 | func_foldl = foldl 631 | 632 | func_foldl1 :: (Husky a) => (a -> a -> a) -> [a] -> a 633 | func_foldl1 _ [] = defVal 634 | func_foldl1 f xs = foldl1 f xs 635 | 636 | func_foldr :: (a -> b -> b) -> b -> [a] -> b 637 | func_foldr = foldr 638 | 639 | func_foldr1 :: (Husky a) => (a -> a -> a) -> [a] -> a 640 | func_foldr1 _ [] = defVal 641 | func_foldr1 f xs = foldr1 f xs 642 | 643 | 644 | func_take :: TNum -> [a] -> [a] 645 | func_take n 646 | | n >= 0 = genericTake n 647 | | otherwise = reverse . genericTake (-n) . reverse 648 | 649 | func_take2 :: [a] -> TNum -> [a] 650 | func_take2 = flip func_take 651 | 652 | func_takew :: Concrete b => (a -> b) -> [a] -> [a] 653 | func_takew _ [] = [] 654 | func_takew f (x:xs) 655 | | isTruthy(f x) = x : func_takew f xs 656 | | otherwise = [] 657 | 658 | func_drop :: TNum -> [a] -> [a] 659 | func_drop n 660 | | n >= 0 = genericDrop n 661 | | otherwise = reverse . genericDrop (-n) . reverse 662 | 663 | func_drop2 :: [a] -> TNum -> [a] 664 | func_drop2 = flip func_drop 665 | 666 | func_dropw :: Concrete b => (a -> b) -> [a] -> [a] 667 | func_dropw _ [] = [] 668 | func_dropw f (x:xs) 669 | | isTruthy(f x) = func_dropw f xs 670 | | otherwise = x:xs 671 | 672 | func_span :: Concrete b => (a -> b) -> [a] -> ([a],[a]) 673 | func_span f xs = go f ([],xs) 674 | where go f result@(hs,(t:ts)) | isTruthy(f t) = go f (hs++[t],ts) 675 | | otherwise = result 676 | go f (hs,[]) = (hs,[]) 677 | 678 | func_list :: b -> (a -> [a] -> b) -> [a] -> b 679 | func_list c _ [] = c 680 | func_list _ f (x:xs) = f x xs 681 | 682 | func_listN :: (Husky b) => (a -> [a] -> b) -> [a] -> b 683 | func_listN _ [] = defVal 684 | func_listN f (x:xs) = f x xs 685 | 686 | func_listF :: b -> (([a] -> b) -> (a -> [a] -> b)) -> [a] -> b 687 | func_listF c f = go 688 | where go [] = c 689 | go (x:xs) = f go x xs 690 | 691 | func_listNF :: (Husky b) => (([a] -> b) -> (a -> [a] -> b)) -> [a] -> b 692 | func_listNF f = go 693 | where go [] = defVal 694 | go (x:xs) = f go x xs 695 | 696 | func_fork :: (a -> b -> c) -> (x -> a) -> (x -> b) -> x -> c 697 | func_fork f g h x = f (g x) (h x) 698 | 699 | func_fork2 :: (a -> b -> c) -> (x -> y -> a) -> (x -> y -> b) -> x -> y -> c 700 | func_fork2 f g h x y = f (g x y) (h x y) 701 | 702 | func_argdup :: (a -> a -> b) -> a -> b 703 | func_argdup f x = f x x 704 | 705 | func_iter :: (a -> a) -> a -> [a] 706 | func_iter = iterate 707 | 708 | func_iterL :: (a -> [a]) -> [a] -> [a] 709 | func_iterL f = go 710 | where go [] = [] 711 | go xs = xs ++ go (concatMap f xs) 712 | 713 | func_iterP :: ([a] -> a) -> [a] -> [a] 714 | func_iterP f = \as -> as ++ go as 715 | where go xs | x <- f xs = x : go (xs ++ [x]) 716 | 717 | func_rep :: a -> [a] 718 | func_rep = repeat 719 | 720 | func_ord :: Char -> TNum 721 | func_ord = fromIntegral.ord 722 | 723 | func_chr :: TNum -> Char 724 | func_chr = chr.fromInteger.toInteger 725 | 726 | func_show :: Concrete a => a -> String 727 | func_show = show 728 | 729 | func_empty :: [a] 730 | func_empty = [] 731 | 732 | func_predN :: TNum -> TNum 733 | func_predN n = n-1 734 | 735 | func_succN :: TNum -> TNum 736 | func_succN n = n+1 737 | 738 | func_predC :: Char -> Char 739 | func_predC = pred 740 | 741 | func_succC :: Char -> Char 742 | func_succC = succ 743 | 744 | func_elem :: Concrete a => [a] -> a -> TNum 745 | func_elem xs x | Just i <- elemIndex x xs = fromIntegral i + 1 746 | | otherwise = 0 747 | 748 | func_elem' :: Concrete a => a -> [a] -> TNum 749 | func_elem' = flip func_elem 750 | 751 | func_sort :: Concrete a => [a] -> [a] 752 | func_sort = sort 753 | 754 | func_sorton :: Concrete b => (a -> b) -> [a] -> [a] 755 | func_sorton = sortOn 756 | 757 | -- f x y means x is greater then y 758 | func_sortby :: Concrete b => (a -> a -> b) -> [a] -> [a] 759 | func_sortby f xs = sortOn (\x -> length [y | y <- xs, isTruthy $ f x y]) xs 760 | 761 | func_max :: Concrete a => a -> a -> a 762 | func_max = max 763 | 764 | func_min :: Concrete a => a -> a -> a 765 | func_min = min 766 | 767 | func_maxl :: Concrete a => [a] -> a 768 | func_maxl = foldr max func_minval 769 | 770 | func_minl :: Concrete a => [a] -> a 771 | func_minl = foldr min func_maxval 772 | 773 | func_del :: Concrete a => a -> [a] -> [a] 774 | func_del = delete 775 | 776 | func_diffl :: Concrete a => [a] -> [a] -> [a] 777 | func_diffl [] xs = xs 778 | --first option: multiset difference 779 | func_diffl (y:ys) xs = func_diffl ys $ func_del y xs 780 | --second option: filter elements (disregards multiciplities) 781 | --func_diffl (y:ys) xs = func_diffl ys $ filter (/=y) xs 782 | 783 | func_nub :: Concrete a => [a] -> [a] 784 | func_nub = nub 785 | 786 | func_nubon :: Concrete b => (a -> b) -> [a] -> [a] 787 | func_nubon f = nubBy (\x y -> f x == f y) 788 | 789 | func_nubby :: Concrete b => (a -> a -> b) -> [a] -> [a] 790 | func_nubby f = nubBy (\x y -> isTruthy $ f x y) 791 | 792 | func_words :: [Char] -> [[Char]] 793 | func_words = words 794 | 795 | func_unwords :: [[Char]] -> [Char] 796 | func_unwords = unwords 797 | 798 | func_lines :: [Char] -> [[Char]] 799 | func_lines = lines 800 | 801 | func_unlines :: [[Char]] -> [Char] 802 | func_unlines = unlines 803 | 804 | func_pfac :: TNum -> [TNum] 805 | func_pfac = factorize 2 806 | where factorize _ 1 = [] 807 | factorize d n 808 | | d * d > n = [n] 809 | | n `mod` d == 0 = d : factorize d (n `div` d) 810 | | otherwise = factorize (d + 1) n 811 | 812 | func_subs :: Concrete a => a -> a -> [a] -> [a] 813 | func_subs x y = map (\z -> if z == x then y else z) 814 | 815 | func_subs2 :: Concrete a => [a] -> [a] -> [a] -> [a] 816 | func_subs2 _ _ [] = [] 817 | func_subs2 x y s@(h:t) | Just s2 <- stripPrefix x s = y++func_subs2 x y s2 818 | | otherwise = h : func_subs2 x y t 819 | 820 | func_group :: Concrete a => [a] -> [[a]] 821 | func_group = group 822 | 823 | func_groupOn :: Concrete b => (a -> b) -> [a] -> [[a]] 824 | func_groupOn f = groupBy (\x y -> f x == f y) 825 | 826 | func_groupBy :: Concrete b => (a -> a -> b) -> [a] -> [[a]] 827 | func_groupBy _ [] = [] 828 | func_groupBy p (a:as) = consHead a $ go a as 829 | where go _ [] = [[]] 830 | go a (x:xs) | isTruthy $ p a x = consHead x $ go x xs 831 | | otherwise = [] : consHead x (go x xs) 832 | consHead x ~(xs:xss) = (x:xs):xss 833 | 834 | func_perms :: [a] -> [[a]] 835 | func_perms = permutations 836 | 837 | func_subl :: Concrete a => [a] -> [a] -> TNum 838 | func_subl super sub = subindex 1 super sub 839 | where subindex i _ [] = i 840 | subindex i super@(_:xs) sub = if sub`isPrefixOf`super then i else subindex (i+1) xs sub 841 | subindex _ [] _ = 0 842 | 843 | -- Index of first truthy, or 0 844 | func_any :: Concrete b => (a->b) -> [a] -> TNum 845 | func_any f = go 1 846 | where go _ [] = 0 847 | go n (x:xs) 848 | | isTruthy $ f x = n 849 | | otherwise = go (n+1) xs 850 | 851 | -- Length + 1 or 0 852 | func_all :: Concrete b => (a->b) -> [a] -> TNum 853 | func_all f = go 1 854 | where go n [] = n 855 | go n (x:xs) 856 | | isTruthy $ f x = go (n+1) xs 857 | | otherwise = 0 858 | 859 | func_trsp :: [[a]] -> [[a]] 860 | func_trsp = transpose 861 | 862 | --Transpose with -> turns into a square matrix before transposing, padding with the given element 863 | func_trspw :: a -> [[a]] -> [[a]] 864 | func_trspw padding rows | all null rows = [] 865 | | otherwise = map (headwith padding) rows : func_trspw padding (map (drop 1) rows) 866 | where headwith _ (x:_) = x 867 | headwith padding _ = padding 868 | 869 | --Zip, but keep extra elements from the longer list unaltered 870 | func_zip' :: (a -> a -> a) -> [a] -> [a] -> [a] 871 | func_zip' _ [] ys = ys 872 | func_zip' _ xs [] = xs 873 | func_zip' f (x:xs) (y:ys) = f x y : func_zip' f xs ys 874 | 875 | func_cmap :: (a -> [b]) -> [a] -> [b] 876 | func_cmap = concatMap 877 | 878 | func_smap :: (a -> TNum) -> [a] -> TNum 879 | func_smap f = sum . map f 880 | 881 | func_cmapr :: [(a -> [b])] -> a -> [b] 882 | func_cmapr fs = concat . func_mapr fs 883 | 884 | func_smapr :: [(a -> TNum)] -> a -> TNum 885 | func_smapr fs = sum . func_mapr fs 886 | 887 | func_combin :: (b -> b -> c) -> (a -> b) -> a -> a -> c 888 | func_combin f g x y = f (g x) (g y) 889 | 890 | func_n2i :: TNum -> TNum 891 | func_n2i x = func_floor $ x+1/2 --round halves towards positive infinity 892 | 893 | func_c2i :: Char -> TNum 894 | func_c2i c | Just i <- elemIndex c "0123456789" = fromIntegral i 895 | | otherwise = 0 896 | 897 | -- Read the first number found in the string, or 0 if nothing found 898 | func_s2i :: String -> TNum 899 | func_s2i s = case takeWhile C.isDigit $ dropWhile (not . C.isDigit) s of 900 | "" -> 0 901 | x -> read x 902 | 903 | func_list2 :: a -> a -> [a] 904 | func_list2 x y = [x,y] 905 | 906 | func_list3 :: a -> a -> a -> [a] 907 | func_list3 x y z = [x,y,z] 908 | 909 | func_list4 :: a -> a -> a -> a -> [a] 910 | func_list4 x y z t = [x,y,z,t] 911 | 912 | func_nubw :: Concrete a => [a] -> [a] 913 | func_nubw xs = go [] xs 914 | where go ys (x:xs) | elem x ys = [] 915 | | otherwise = x:go (x:ys) xs 916 | go _ [] = [] 917 | 918 | func_table :: (a -> b -> c) -> [a] -> [b] -> [[c]] 919 | func_table f as bs = [[f a b | b <- bs] | a <- as] 920 | 921 | func_lmap :: (a -> b -> c) -> [a] -> b -> [c] 922 | func_lmap f as b = map (flip f b) as 923 | 924 | func_rmap :: (a -> b -> c) -> a -> [b] -> [c] 925 | func_rmap f a = map (f a) 926 | 927 | func_mapacL :: (a -> b -> a) -> (a -> b -> c) -> a -> [b] -> [c] 928 | func_mapacL _ _ _ [] = [] 929 | func_mapacL f g x (y:ys) = g x y : func_mapacL f g (f x y) ys 930 | 931 | func_mapacR :: (b -> a -> a) -> (b -> a -> c) -> a -> [b] -> [c] 932 | func_mapacR _ _ _ [] = [] 933 | func_mapacR f g x (y:ys) = g y (foldr f x ys) : func_mapacR f g x ys 934 | 935 | func_replic :: TNum -> a -> [a] 936 | func_replic n = replicate $ fromInteger $ toInteger n 937 | 938 | func_replif :: a -> TNum -> [a] 939 | func_replif = flip func_replic 940 | 941 | func_abs :: TNum -> TNum 942 | func_abs = abs 943 | 944 | func_sign :: TNum -> TNum 945 | func_sign = signum 946 | 947 | -- x y -> base-x digits of y 948 | func_base :: TNum -> TNum -> [TNum] 949 | func_base 0 n = [n] 950 | func_base 1 n 951 | | (d, m) <- divMod n 1, m /= 0 = func_base 1 d ++ [m] 952 | | otherwise = replicate (fromInteger $ toInteger $ abs n) $ signum n 953 | func_base (-1) n 954 | | (d, m) <- divMod n 1, m /= 0 = go (func_base (-1) d) m 955 | | n > 0 = func_take (2*abs n - 1) $ cycle [1, 0] 956 | | otherwise = func_take (2*abs n) $ cycle [1, 0] 957 | where go [] m = [m] 958 | go [0] m = [m] 959 | go [k] m = [k,0,m] 960 | go (k:ks) m = k : go ks m 961 | func_base b n = reverse $ go n 962 | where go m | m >= 0 || b > 0, abs m < abs b = [m] 963 | | (d, r) <- divMod m b = 964 | if r >= 0 || b > 0 965 | then r : go d 966 | else r-b : go (d+1) 967 | 968 | func_base2 :: TNum -> [TNum] 969 | func_base2 = func_base 2 970 | 971 | func_base10 :: TNum -> [TNum] 972 | func_base10 = func_base 10 973 | 974 | -- x y -> y interpreted in base x 975 | func_abase :: TNum -> [TNum] -> TNum 976 | func_abase b ds = sum [b^n * d | (n, d) <- zip [0..] $ reverse ds] 977 | 978 | func_abase2 :: [TNum] -> TNum 979 | func_abase2 = func_abase 2 980 | 981 | func_abas10 :: [TNum] -> TNum 982 | func_abas10 = func_abase 10 983 | 984 | func_double :: TNum -> TNum 985 | func_double = (* 2) 986 | 987 | func_halve :: TNum -> TNum 988 | func_halve n = n / 2 989 | 990 | -- a b -> b^a 991 | func_power :: TNum -> TNum -> TNum 992 | func_power (m :% 1) n 993 | | m >= 0 = n^m 994 | | otherwise = n^^m 995 | func_power m n = n**m 996 | 997 | func_square :: TNum -> TNum 998 | func_square n = n * n 999 | 1000 | -- Should return a rational if input is a perfect square 1001 | func_sqrt :: TNum -> TNum 1002 | func_sqrt n | n < 0 = -func_sqrt (-n) 1003 | func_sqrt (p :% q) | Just r <- isqrt p, 1004 | Just s <- isqrt q 1005 | = r :% s 1006 | func_sqrt d = d**(1/2) 1007 | 1008 | isqrt :: Integer -> Maybe Integer 1009 | isqrt n = go n $ div (n+1) 2 1010 | where go a b | a <= b, 1011 | a*a == n = Just a 1012 | | a <= b = Nothing 1013 | | otherwise = go b $ div (b + div n b) 2 1014 | 1015 | hasLength m [] = m <= 0 1016 | hasLength m (x:xs) = m <= 0 || hasLength (m-1) xs 1017 | 1018 | func_slice :: TNum -> [a] -> [[a]] 1019 | func_slice n | n < 0 = map (genericTake (-n)) . init . tails 1020 | func_slice n = takeWhile ((>= n) . genericLength) . map (genericTake n) . tails 1021 | 1022 | func_cuts :: [TNum] -> [a] -> [[a]] 1023 | func_cuts [] _ = [] 1024 | func_cuts _ [] = [] 1025 | func_cuts (m:ms) xs 1026 | | m < 0, (ys, zs) <- genericSplitAt (-m) $ reverse xs 1027 | = reverse ys : func_cuts ms (reverse zs) 1028 | | (ys, zs) <- genericSplitAt m xs 1029 | = ys : func_cuts ms zs 1030 | 1031 | func_cut :: TNum -> [a] -> [[a]] 1032 | func_cut n | n < 0 = map reverse . reverse . func_cuts (repeat (-n)) . reverse 1033 | | otherwise = func_cuts $ repeat n 1034 | 1035 | func_mapad2 :: (a -> a -> b) -> [a] -> [b] 1036 | func_mapad2 _ [] = [] 1037 | func_mapad2 f xs = zipWith f xs $ tail xs 1038 | 1039 | func_mapad3 :: (a -> a -> a -> b) -> [a] ->[b] 1040 | func_mapad3 _ [] = [] 1041 | func_mapad3 _ [_] = [] 1042 | func_mapad3 f xs = zipWith3 f xs (tail xs) $ tail $ tail xs 1043 | 1044 | func_join :: [a] -> [[a]] -> [a] 1045 | func_join x = concat . go 1046 | where go [] = [] 1047 | go [y] = [y] 1048 | go (y:ys) = y : x : go ys 1049 | 1050 | func_join' :: a -> [[a]] -> [a] 1051 | func_join' = func_join . pure 1052 | 1053 | func_powset :: [a] -> [[a]] 1054 | func_powset = subsequences 1055 | 1056 | func_oelem :: Concrete a => [a] -> a -> TNum 1057 | func_oelem = go 1 1058 | where go _ [] _ = 0 1059 | go n (x:xs) y | y>x = go (n+1) xs y 1060 | | y==x = n 1061 | | otherwise = 0 1062 | 1063 | func_oelem' :: Concrete a => a -> [a] -> TNum 1064 | func_oelem' = flip func_oelem 1065 | 1066 | func_isprime :: TNum -> TNum 1067 | func_isprime p | n :% 1 <- p, 1068 | n >= 2, 1069 | probablePrime n 1070 | = func_oelem primes_list p 1071 | | otherwise = 0 1072 | where 1073 | probablePrime :: Integer -> Bool 1074 | probablePrime n 1075 | | elem n [2,3,5,7] = True 1076 | | any (\p -> rem n p == 0) [2,3,5,7] = False 1077 | | not $ fermatProbPrime 2 n = False 1078 | | Nothing <- isqrt n, 1079 | d <- [d | d <- zipWith (*) [5,7..] $ cycle [1, -1], jacobi d n == -1]!!0 1080 | = lucasProbPrime d n 1081 | | otherwise = True 1082 | oddify :: Integer -> (Integer, Integer) 1083 | oddify k 1084 | | even k, (d, s) <- oddify (div k 2) = (d, s+1) 1085 | | otherwise = (k, 0) 1086 | fermatProbPrime :: Integer -> Integer -> Bool 1087 | fermatProbPrime a n 1088 | | (d, s) <- oddify $ n-1 1089 | = rem (a^d) n == 1 || or [rem (a^(d*(2^r))) n == n-1 | r <- [0..s-1]] 1090 | | otherwise = False 1091 | jacobi :: Integer -> Integer -> Integer 1092 | jacobi _ 1 = 1 1093 | jacobi 1 _ = 1 1094 | jacobi 0 _ = 0 1095 | jacobi a k 1096 | | a < 0 || a >= k = jacobi (mod a k) k 1097 | | even a = (-1)^(div(k*k-1)8) * jacobi (div a 2) k 1098 | | gcd a k > 1 = 0 1099 | | otherwise = (-1)^(div((a-1)*(k-1))4) * jacobi k a 1100 | -- For Lucas sequences, we choose P = 1, Q = (1-D)/4 1101 | lucasUVQ :: Integer -> Integer -> Integer -> (Integer, Integer, Integer) 1102 | lucasUVQ n d = go 1103 | where q = div (1-d) 4 1104 | toEven r | odd r = r + n 1105 | | otherwise = r 1106 | go 0 = (0, 2, 1) 1107 | go 1 = (1, 1, q) 1108 | go k | even k, (u, v, qk) <- go $ div k 2 = (rem (u*v) n, rem (v*v - 2*qk) n, rem (qk*qk) n) 1109 | | (u, v, qk) <- go $ k-1 = (div (toEven $ u + v) 2, div (toEven $ d*u + v) 2, rem (qk*q) n) 1110 | -- For the Lucas test, we choose P = 1 1111 | lucasProbPrime :: Integer -> Integer -> Bool 1112 | lucasProbPrime d n 1113 | | (u, _, _) <- lucasUVQ n d (n+1) 1114 | = mod u n == 0 1115 | 1116 | func_slices :: [a] -> [[a]] 1117 | func_slices xs = reverse . init . tails =<< inits xs 1118 | 1119 | func_clone :: TNum -> [a] -> [a] 1120 | func_clone n = concatMap $ func_replic n 1121 | 1122 | func_clone' :: [a] -> TNum -> [a] 1123 | func_clone' = flip func_clone 1124 | 1125 | func_clones :: [TNum] -> [a] -> [a] 1126 | func_clones ns xs = concat $ zipWith func_replic ns xs 1127 | 1128 | func_cycle :: [a] -> [a] 1129 | func_cycle [] = [] 1130 | func_cycle xs = cycle xs 1131 | 1132 | func_cumsum :: [TNum] -> [TNum] 1133 | func_cumsum = tail . scanl (+) 0 1134 | 1135 | func_cumcat :: [[a]] -> [[a]] 1136 | func_cumcat = tail . scanl (++) [] 1137 | 1138 | func_isanum :: Char -> TNum 1139 | func_isanum c = 1140 | if C.isAlphaNum c 1141 | then func_ord c 1142 | else 0 1143 | 1144 | func_isalph :: Char -> TNum 1145 | func_isalph c = 1146 | if C.isAlpha c 1147 | then func_ord c 1148 | else 0 1149 | 1150 | func_isuppr :: Char -> TNum 1151 | func_isuppr c = 1152 | if C.isUpper c 1153 | then func_ord c 1154 | else 0 1155 | 1156 | func_islowr :: Char -> TNum 1157 | func_islowr c = 1158 | if C.isLower c 1159 | then func_ord c 1160 | else 0 1161 | 1162 | func_isdigt :: Char -> TNum 1163 | func_isdigt c = 1164 | if C.isDigit c 1165 | then func_ord c 1166 | else 0 1167 | 1168 | func_touppr :: Char -> Char 1169 | func_touppr = C.toUpper 1170 | 1171 | func_tolowr :: Char -> Char 1172 | func_tolowr = C.toLower 1173 | 1174 | func_swcase :: Char -> Char 1175 | func_swcase c = if C.isUpper c then C.toLower c else C.toUpper c 1176 | 1177 | func_ceil :: TNum -> TNum 1178 | func_ceil a@(_ :% 0) = a 1179 | func_ceil x = ceiling x 1180 | 1181 | func_floor :: TNum -> TNum 1182 | func_floor a@(_ :% 0) = a 1183 | func_floor x = floor x 1184 | 1185 | func_gcd :: TNum -> TNum -> TNum 1186 | func_gcd = gcd 1187 | 1188 | func_lcm :: TNum -> TNum -> TNum 1189 | func_lcm = lcm 1190 | 1191 | func_small :: TNum -> TNum 1192 | func_small = boolToNum . (<= 1) . abs 1193 | 1194 | func_twice :: (a -> a) -> (a -> a) 1195 | func_twice f = \x -> f (f x) 1196 | 1197 | func_divmod :: TNum -> TNum -> [TNum] 1198 | func_divmod m n = [func_idiv m n, func_mod m n] 1199 | 1200 | func_powstN :: TNum -> [a] -> [[a]] 1201 | func_powstN n 1202 | | n < 0 = \xs -> foldl merge2 [] $ map (flip only xs) [0 .. -n] 1203 | | otherwise = only n 1204 | where only n [] = [[] | 0 <= n && n < 1] 1205 | only n (x:xs) 1206 | | 0 <= n && n < 1 = [[]] 1207 | | otherwise = map (x:) (only (n-1) xs) `merge2` only n xs 1208 | 1209 | func_rangeN :: TNum -> TNum -> [TNum] 1210 | func_rangeN a b | a <= b = [a .. b] 1211 | | otherwise = [a, a-1 .. b] 1212 | 1213 | func_rangeC :: Char -> Char -> [Char] 1214 | func_rangeC a b | a <= b = [a .. b] 1215 | | otherwise = [a, pred a .. b] 1216 | 1217 | func_find :: (Husky a, Concrete b) => (a -> b) -> [a] -> a 1218 | func_find f = func_head . func_filter f 1219 | 1220 | func_findN :: (Concrete a) => (TNum -> a) -> TNum -> TNum 1221 | func_findN f n = func_find f [n..] 1222 | 1223 | func_same :: (Concrete a) => [a] -> TNum 1224 | func_same [] = 1 1225 | func_same (x:xs) = 1226 | if all (==x) xs 1227 | then func_len xs + 2 1228 | else 0 1229 | 1230 | func_single :: [a] -> TNum 1231 | func_single [_] = 1 1232 | func_single _ = 0 1233 | 1234 | func_iter2 :: (x -> (x,y)) -> x -> [y] 1235 | func_iter2 f = map (snd . f) . iterate (fst . f) 1236 | 1237 | rangify :: (Enum a, Ord a) => [a] -> [a] 1238 | rangify (m:ns@(n:_)) = range ++ rangify ns 1239 | where range | m < n = [m .. pred n] 1240 | | m > n = [m, pred m .. succ n] 1241 | | m == n = [m] 1242 | rangify ns = ns 1243 | 1244 | func_rangeL :: [TNum] -> [TNum] 1245 | func_rangeL = rangify 1246 | 1247 | func_rangeS :: [Char] -> [Char] 1248 | func_rangeS = rangify 1249 | 1250 | func_joinE :: [a] -> [a] -> [a] 1251 | func_joinE xs ys = func_join xs $ map pure ys 1252 | 1253 | func_branch :: (x -> y -> z) -> (a -> x) -> (b -> y) -> a -> b -> z 1254 | func_branch f g h x y = f (g x) (h y) 1255 | 1256 | func_rotate :: TNum -> [a] -> [a] 1257 | func_rotate n xs | n >= 0 = iterate lrot xs !! fromIntegral n 1258 | | otherwise = iterate rrot xs !! fromIntegral (-n) 1259 | where lrot [] = [] 1260 | lrot (x:xs) = xs ++ [x] 1261 | rrot [] = [] 1262 | rrot xs = last xs : init xs 1263 | 1264 | func_rotatf :: [a] -> TNum -> [a] 1265 | func_rotatf = flip func_rotate 1266 | 1267 | func_bhook :: (x -> y -> z) -> (x -> u -> y) -> x -> u -> z 1268 | func_bhook f g a b = f a (g a b) 1269 | 1270 | func_bhookf :: (x -> y -> z) -> (u -> y -> x) -> u -> y -> z 1271 | func_bhookf f g a b = f (g a b) b 1272 | 1273 | func_until :: Concrete b => (a -> b) -> (a -> a) -> a -> a 1274 | func_until p = until (isTruthy . p) 1275 | 1276 | func_divs :: TNum -> [TNum] 1277 | func_divs n = [d | d <- [1..n], isTruthy $ func_divds d n] 1278 | 1279 | func_uwshow :: Concrete a => [a] -> [Char] 1280 | func_uwshow = unwords . map show 1281 | 1282 | func_ulshow :: Concrete a => [a] -> [Char] 1283 | func_ulshow = unlines . map show 1284 | 1285 | func_decorM :: (((a, b) -> c) -> [(a,b)] -> [[(a, b')]]) -> (a -> b -> c) -> [a] -> [b] -> [[b']] 1286 | func_decorM f g xs ys = map (map snd) $ f (uncurry g) $ zip xs ys 1287 | 1288 | func_decorL :: (((a, b) -> c) -> [(a,b)] -> [(a, b')]) -> (a -> b -> c) -> [a] -> [b] -> [b'] 1289 | func_decorL f g xs ys = map snd $ f (uncurry g) $ zip xs ys 1290 | 1291 | func_decorV :: (((a, b) -> c) -> [(a,b)] -> (a, b')) -> (a -> b -> c) -> [a] -> [b] -> b' 1292 | func_decorV f g xs ys = snd $ f (uncurry g) $ zip xs ys 1293 | 1294 | func_decorN :: (((a, b) -> c) -> [(a,b)] -> d) -> (a -> b -> c) -> [a] -> [b] -> d 1295 | func_decorN f g xs ys = f (uncurry g) $ zip xs ys 1296 | 1297 | func_prep0 :: Husky a => [a] -> [a] 1298 | func_prep0 xs = defVal:xs 1299 | 1300 | func_doubL :: [a] -> [a] 1301 | func_doubL xs = xs++xs 1302 | 1303 | func_halfL :: [a] -> [[a]] 1304 | func_halfL xs = go xs xs where 1305 | go (y:_:ys) (z:zs) = let [zs',zs''] = go ys zs in [z:zs',zs''] 1306 | go (y:ys) (z:zs) = [[z],zs] 1307 | go _ zs = [[],zs] 1308 | 1309 | -- Merge a potentially infinite number of potentially infinite lists 1310 | -- Each list is assumed to be sorted 1311 | -- If there are more than two lists, the heads are assumed to be sorted as well 1312 | func_merge :: (Concrete a) => [[a]] -> [a] 1313 | func_merge [] = [] 1314 | func_merge [xs] = xs 1315 | func_merge ([]:xss) = func_merge xss 1316 | func_merge [xs, []] = xs 1317 | func_merge [xs@(x:_), ys@(y:_)] | x > y = func_merge [ys, xs] 1318 | func_merge ((x:xs):yss) = x : func_merge (put xs yss) 1319 | where put [] yss = yss 1320 | put xs [] = [xs] 1321 | put xs ([]:yss) = put xs yss 1322 | put xs@(x:_) yss@(ys@(y:_):zss) 1323 | | x <= y = xs : yss 1324 | | otherwise = ys : put xs zss 1325 | 1326 | -- Minima and maxima with custom comparison 1327 | -- p x y means x is greater then y 1328 | 1329 | func_minby :: Concrete b => (a -> a -> b) -> a -> a -> a 1330 | func_minby p x y = if isTruthy $ p x y then y else x 1331 | 1332 | func_maxby :: Concrete b => (a -> a -> b) -> a -> a -> a 1333 | func_maxby p x y = if isTruthy $ p x y then x else y 1334 | 1335 | func_minon :: Concrete b => (a -> b) -> a -> a -> a 1336 | func_minon f x y = if f x <= f y then x else y 1337 | 1338 | func_maxon :: Concrete b => (a -> b) -> a -> a -> a 1339 | func_maxon f x y = if f x <= f y then y else x 1340 | 1341 | func_minlby :: (Husky a, Concrete b) => (a -> a -> b) -> [a] -> a 1342 | func_minlby _ [] = defVal 1343 | func_minlby p xs = snd $ minimumBy (comparing fst) $ map (\x -> (length [y | y <- xs, isTruthy $ p x y], x)) xs 1344 | 1345 | func_maxlby :: (Husky a, Concrete b) => (a -> a -> b) -> [a] -> a 1346 | func_maxlby _ [] = defVal 1347 | func_maxlby p xs = snd $ maximumBy (comparing fst) $ map (\x -> (length [y | y <- xs, isTruthy $ p x y], x)) xs 1348 | 1349 | func_minlon :: (Husky a, Concrete b) => (a -> b) -> [a] -> a 1350 | func_minlon _ [] = defVal 1351 | func_minlon f xs = foldr1 (func_minon f) xs 1352 | 1353 | func_maxlon :: (Husky a, Concrete b) => (a -> b) -> [a] -> a 1354 | func_maxlon _ [] = defVal 1355 | func_maxlon f xs = foldr1 (func_maxon f) xs 1356 | 1357 | 1358 | func_aptp :: (a -> b -> c) -> (a, b) -> c 1359 | func_aptp f (x, y) = f x y 1360 | 1361 | func_apftp :: (a -> b -> c) -> (b, a) -> c 1362 | func_apftp f (x, y) = f y x 1363 | 1364 | func_scltp :: (a -> b -> c) -> (a, b) -> (c, b) 1365 | func_scltp f (x, y) = (f x y, y) 1366 | 1367 | func_scrtp :: (a -> b -> c) -> (a, b) -> (a, c) 1368 | func_scrtp f (x, y) = (x, f x y) 1369 | 1370 | func_maptp :: (a -> b) -> (a, a) -> (b, b) 1371 | func_maptp f (x, y) = (f x, f y) 1372 | 1373 | func_lmaptp :: (a -> c) -> (a, b) -> (c, b) 1374 | func_lmaptp f (x, y) = (f x, y) 1375 | 1376 | func_rmaptp :: (b -> c) -> (a, b) -> (a, c) 1377 | func_rmaptp f (x, y) = (x, f y) 1378 | 1379 | 1380 | func_adiags :: [[a]] -> [[a]] 1381 | func_adiags = func_init . go 1 1382 | where go _ [] = [] 1383 | go n xss = 1384 | let (prefix, suffix) = splitAt n xss 1385 | (diag, rests) = unzip [(x, xs) | (x:xs) <- prefix] 1386 | in diag : go (length diag + 1) (rests ++ suffix) 1387 | 1388 | func_lrange :: TNum -> [TNum] 1389 | func_lrange n | n >= 0 = [0 .. n-1] 1390 | | otherwise = [n+1 .. 0] 1391 | 1392 | func_ixes :: [x] -> [TNum] 1393 | func_ixes = zipWith const [1..] 1394 | 1395 | func_srange :: TNum -> [TNum] 1396 | func_srange n | n >= 0 = [-n .. n] 1397 | | otherwise = [-n, -n-1 .. n] 1398 | 1399 | func_rvixes :: [x] -> [TNum] 1400 | func_rvixes xs = reverse [1 .. genericLength xs] 1401 | 1402 | func_cpow :: TNum -> [x] -> [[x]] 1403 | func_cpow n xs = func_cartes $ func_replic n xs 1404 | 1405 | func_cpow' :: [x] -> TNum -> [[x]] 1406 | func_cpow' = flip func_cpow 1407 | 1408 | func_cpowN :: TNum -> TNum -> [[TNum]] 1409 | func_cpowN n = func_cpow n . func_heads 1410 | 1411 | func_toadjM :: (((a, a) -> c) -> [(a,a)] -> [[(a, a)]]) -> (a -> a -> c) -> [a] -> [[a]] 1412 | func_toadjM f g xs = func_decorM f g (func_tail xs) xs 1413 | 1414 | func_toadjL :: (((a, a) -> c) -> [(a,a)] -> [(a, a)]) -> (a -> a -> c) -> [a] -> [a] 1415 | func_toadjL f g xs = func_decorL f g (func_tail xs) xs 1416 | 1417 | func_toadjV :: (((a, a) -> c) -> [(a,a)] -> (a, a)) -> (a -> a -> c) -> [a] -> a 1418 | func_toadjV f g xs = func_decorV f g (func_tail xs) xs 1419 | 1420 | func_toadjN :: (((a, a) -> c) -> [(a,a)] -> b) -> (a -> a -> c) -> [a] -> b 1421 | func_toadjN f g xs = func_decorN f g (func_tail xs) xs 1422 | 1423 | func_all2 :: Concrete y => (x -> x -> y) -> [x] -> TNum 1424 | func_all2 _ [] = 1 1425 | func_all2 pred xs = 1426 | case func_toadjN func_all pred xs of 1427 | 0 -> 0 1428 | n -> n + 1 1429 | 1430 | func_any2 :: Concrete y => (x -> x -> y) -> [x] -> TNum 1431 | func_any2 = func_toadjN func_any 1432 | 1433 | func_count2 :: Concrete y => (x -> x -> y) -> [x] -> TNum 1434 | func_count2 = func_toadjN func_countf 1435 | 1436 | func_sameon :: Concrete y => (x -> y) -> [x] -> TNum 1437 | func_sameon f = func_same . map f 1438 | 1439 | func_sameby :: Concrete y => (x -> x -> y) -> [x] -> TNum 1440 | func_sameby p xs = 1441 | if and [isTruthy $ p x y | (x:ys) <- tails xs, y <- ys] 1442 | then func_len xs + 1 1443 | else 0 1444 | 1445 | func_keyon :: Concrete y => (x -> y) -> [x] -> [[x]] 1446 | func_keyon f = func_groupOn f . func_sorton f 1447 | 1448 | func_keyby :: Concrete y => (x -> x -> y) -> [x] -> [[x]] 1449 | func_keyby p = go [] 1450 | where go yss [] = yss 1451 | go yss (x:xs) = go (put x yss) xs 1452 | put x [] = [[x]] 1453 | put x (ys:yss) | and [isTruthy $ p y x | y <- ys] = (ys++[x]) : yss 1454 | | otherwise = ys : put x yss 1455 | 1456 | func_unzip :: [(x, y)] -> ([x], [y]) 1457 | func_unzip = unzip 1458 | 1459 | func_split :: Concrete x => x -> [x] -> [[x]] 1460 | func_split x = go 1461 | where go [] = [[]] 1462 | go (y:ys) | x == y = [] : go ys 1463 | | (zs:zss) <- go ys = (y:zs) : zss 1464 | | otherwise = [[y]] 1465 | 1466 | func_split' :: Concrete x => [x] -> x -> [[x]] 1467 | func_split' = flip func_split 1468 | 1469 | func_splitL :: Concrete x => [x] -> [x] -> [[x]] 1470 | func_splitL xs = go 1471 | where go [] = [[]] 1472 | go ys | Just zs <- stripPrefix xs ys = [] : go zs 1473 | go (y:ys) | (zs:zss) <- go ys = (y:zs) : zss 1474 | | otherwise = [[y]] 1475 | 1476 | func_joinV :: x -> [x] -> [x] 1477 | func_joinV = intersperse 1478 | 1479 | lenBelow xs n | n <= 0 = False 1480 | lenBelow [] n = True 1481 | lenBelow (_:xs) n = lenBelow xs (n-1) 1482 | 1483 | func_replen :: [x] -> TNum -> [x] 1484 | func_replen [] _ = [] 1485 | func_replen xs n | n < 0 = func_replen (reverse xs) (-n) 1486 | | n == 0 = [] 1487 | | otherwise = go (cycle xs) xs 0 1488 | where go _ [] _ = [] 1489 | go as (_:bs) m | mn <- func_floor $ m+n = func_take mn as ++ go (func_drop mn as) bs (func_mod 1 $ m+n) 1490 | 1491 | func_repln' :: TNum -> [x] -> [x] 1492 | func_repln' = flip func_replen 1493 | 1494 | func_isect :: Concrete x => [x] -> [x] -> [x] 1495 | func_isect [] _ = [] 1496 | func_isect _ [] = [] 1497 | func_isect (x:xs) ys | Just zs <- del ys = x : func_isect xs zs 1498 | | otherwise = func_isect xs ys 1499 | where del [] = Nothing 1500 | del (y:ys) | y == x = Just ys 1501 | | otherwise = (y:) <$> del ys 1502 | 1503 | func_mean :: [TNum] -> TNum 1504 | func_mean [] = 0 1505 | func_mean xs = sum xs / func_len xs 1506 | 1507 | func_cart2 :: [a] -> [a] -> [[a]] 1508 | func_cart2 xs ys = [[x,y] | x <- xs, y <- ys] 1509 | 1510 | func_ccons :: [a] -> [[a]] -> [[a]] 1511 | func_ccons xs yss = [x:ys | x <- xs, ys <- yss] 1512 | 1513 | func_csnoc :: [[a]] -> [a] -> [[a]] 1514 | func_csnoc xss ys = [xs++[y] | xs <- xss, y <- ys] 1515 | 1516 | func_bwand :: TNum -> TNum -> TNum 1517 | func_bwand r s 1518 | | (m, a) <- properFraction r, 1519 | (n, b) <- properFraction s = go (1/2) ((m .&. n) :% 1) a b 1520 | where go _ t 0 _ = t 1521 | go _ t _ 0 = t 1522 | go d t x y | t == t+d = t 1523 | | x < d, y < d = go (d/2) t x y 1524 | | x < d = go (d/2) t x (y-d) 1525 | | y < d = go (d/2) t (x-d) y 1526 | | otherwise = go (d/2) (t+d) (x-d) (y-d) 1527 | 1528 | func_bwor :: TNum -> TNum -> TNum 1529 | func_bwor r s 1530 | | (m, a) <- properFraction r, 1531 | (n, b) <- properFraction s = go (1/2) ((m .|. n) :% 1) a b 1532 | where go _ t 0 0 = t 1533 | go d t x y | t == t+d = t 1534 | | x < d, y < d = go (d/2) t x y 1535 | | x < d = go (d/2) (t+d) x (y-d) 1536 | | y < d = go (d/2) (t+d) (x-d) y 1537 | | otherwise = go (d/2) (t+d) (x-d) (y-d) 1538 | 1539 | func_union :: Concrete x => [x] -> [x] -> [x] 1540 | func_union xs ys = (filter (`notElem` ys) $ nub xs) ++ ys 1541 | 1542 | func_ucons :: Concrete x => x -> [x] -> [x] 1543 | func_ucons x ys = if x `elem` ys then ys else x:ys 1544 | 1545 | func_usnoc :: Concrete x => [x] -> x -> [x] 1546 | func_usnoc xs y = if y `elem` xs then xs else xs++[y] 1547 | 1548 | 1549 | func_uwpshw :: (Concrete a, Concrete b) => (a, b) -> [Char] 1550 | func_uwpshw (a, b) = unwords [show a, show b] 1551 | 1552 | func_ulpshw :: (Concrete a, Concrete b) => (a, b) -> [Char] 1553 | func_ulpshw (a, b) = unlines [show a, show b] 1554 | 1555 | func_subset :: (Concrete a) => [a] -> [a] -> TNum 1556 | func_subset _ [] = 1 1557 | func_subset [] _ = 0 1558 | func_subset xs (y:ys) | Just zs <- del y xs = func_subset zs ys 1559 | | otherwise = 0 1560 | where del a [] = Nothing 1561 | del a (b:bs) | a == b = Just bs 1562 | | otherwise = (b:) <$> del a bs 1563 | 1564 | func_comf :: (x -> y -> z) -> (u -> y) -> x -> u -> z 1565 | func_comf f g = \x y -> f x $ g y 1566 | 1567 | func_comf2 :: (x -> y -> z) -> (u -> v -> y) -> x -> u -> v -> z 1568 | func_comf2 f g = \x y z -> f x $ g y z 1569 | 1570 | func_comf3 :: (x -> y -> z) -> (u -> v -> w -> y) -> x -> u -> v -> w -> z 1571 | func_comf3 f g = \x y z u -> f x $ g y z u 1572 | 1573 | func_comf4 :: (x -> y -> z) -> (u -> v -> w -> t -> y) -> x -> u -> v -> w -> t -> z 1574 | func_comf4 f g = \x y z u v -> f x $ g y z u v 1575 | 1576 | func_gaps :: (Husky a) => TNum -> [a] -> [a] 1577 | func_gaps n = func_gapsL $ repeat n 1578 | 1579 | func_gaps2 :: (Husky a) => [a] -> TNum -> [a] 1580 | func_gaps2 = flip func_gaps 1581 | 1582 | func_gapsL :: (Husky a) => [TNum] -> [a] -> [a] 1583 | func_gapsL ns = concat . zipWith go ns . func_cuts (abs <$> ns) 1584 | where go n | n < 0 = func_drop (-n-1) 1585 | | otherwise = func_take 1 1586 | 1587 | func_cut2 :: [a] -> TNum -> [[a]] 1588 | func_cut2 = flip func_cut 1589 | 1590 | func_chrsum :: [Char] -> TNum 1591 | func_chrsum = func_sum . map func_ord 1592 | 1593 | func_nubwN :: Concrete a => TNum -> [a] -> [a] 1594 | func_nubwN k = go [] . func_slice (abs k) 1595 | where go ys (xs:xss) | elem xs ys = if k < 0 then [] else func_init xs 1596 | | null xss = xs 1597 | | otherwise = func_head xs : go (xs:ys) xss 1598 | go _ [] = [] 1599 | 1600 | func_revnum :: TNum -> TNum 1601 | func_revnum = func_abas10 . func_rev . func_base10 1602 | 1603 | 1604 | func_onixes :: Husky a => ((TNum -> a) -> [TNum] -> b) -> [a] -> b 1605 | func_onixes f xs = f (func_index2 xs) $ func_ixes xs 1606 | 1607 | func_flipap :: b -> (a -> b -> c) -> a -> c 1608 | func_flipap = flip flip 1609 | 1610 | func_cutL :: [[a]] -> [b] -> [[b]] 1611 | func_cutL ((_:xs):xss) (y:ys) | (zs:zss) <- func_cutL (xs:xss) ys = (y:zs):zss 1612 | func_cutL ([]:xss) ys = [] : func_cutL xss ys 1613 | func_cutL [] _ = [] 1614 | func_cutL _ [] = [] 1615 | 1616 | func_ixsof :: (Concrete a) => a -> [a] -> [TNum] 1617 | func_ixsof x ys = [i | (i, y) <- zip [1..] ys, y == x] 1618 | 1619 | func_ixsof2 :: (Concrete a) => [a] -> a -> [TNum] 1620 | func_ixsof2 = flip func_ixsof 1621 | 1622 | func_where :: (Concrete b) => (a -> b) -> [a] -> [TNum] 1623 | func_where f xs = [i | (i, x) <- zip [1..] xs, isTruthy $ f x] 1624 | 1625 | func_where2 :: (Concrete b) => (a -> a -> b) -> [a] -> [TNum] 1626 | func_where2 = func_toadjN func_where 1627 | 1628 | func_idx2d :: Husky a => (TNum, TNum) -> [[a]] -> a 1629 | func_idx2d (x, y) = func_index y . func_index x 1630 | 1631 | func_idx2d2 :: Husky a => [[a]] -> (TNum, TNum) -> a 1632 | func_idx2d2 = flip func_idx2d 1633 | --------------------------------------------------------------------------------