egison 0.1 → 0.1.1
raw patch · 7 files changed
+961/−828 lines, 7 files
Files
- Egison.hs +288/−311
- egison.cabal +13/−10
- etc/elisp/egison-mode.el +153/−0
- etc/sample/list-test.egi +429/−0
- etc/sample/nat-test.egi +78/−0
- sample/list-test.egi +0/−429
- sample/nat-test.egi +0/−78
Egison.hs view
@@ -10,7 +10,7 @@ main :: IO () main = do args <- getArgs case length args of- 0 -> do flushStr "Egison, version 0.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"+ 0 -> do flushStr "Egison, version 0.1.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" defsRef <- newIORef [] runRepl defsRef _ -> putStrLn "Program takes only 0 argument!"@@ -24,19 +24,6 @@ Input str -> runIOThrows ((liftThrows (readTopExpression str)) >>= executeTopExpression defs) >>= putStrLn >> runRepl defs -- Input str -> runIOThrows (liftThrows (liftM show (readTopExpression str))) >>= putStrLn >> runRepl defs -executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String-executeTopExpression defs (Define name expr) = do- liftIO (modifyIORef defs (\ls -> ((name, expr) : ls)))- return name-executeTopExpression defs (Test expr) = do- topFrame <- makeTopFrame defs- val <- eval (Environment [topFrame]) expr- liftIO (showValue val)-executeTopExpression defs Execute = do- topFrame <- makeTopFrame defs- val <- eval (Environment [topFrame]) (ApplyExp (SymbolExp "main") (TupleExp []))- liftIO (showValue val)- readPrompt :: String -> IO Input readPrompt prompt = flushStr prompt >> getExpression @@ -47,49 +34,55 @@ | Eof getExpression :: IO Input-getExpression = catch (do str <- (getExpressionHelper 0)+getExpression = catch (do str <- getExpressionHelper False 0 return (Input str)) (\_ -> return Eof) -getExpressionHelper :: Integer -> IO String-getExpressionHelper n = do c <- getChar- case c of- '(' -> do l <- getExpressionHelper (n + 1)- return (c : l)- '<' -> do l <- getExpressionHelper (n + 1)- return (c : l)- '[' -> do l <- getExpressionHelper (n + 1)- return (c : l)- '{' -> do l <- getExpressionHelper (n + 1)- return (c : l)- ')' -> do l <- getExpressionHelper (n - 1)- return (c : l)- '>' -> do l <- getExpressionHelper (n - 1)- return (c : l)- ']' -> do l <- getExpressionHelper (n - 1)- return (c : l)- '}' -> do l <- getExpressionHelper (n - 1)+getExpressionHelper :: Bool -> Integer -> IO String+getExpressionHelper b n = do c <- getChar+ case c of+ '(' -> do l <- getExpressionHelper True (n + 1)+ return (c : l)+ '<' -> do l <- getExpressionHelper True (n + 1)+ return (c : l)+ '[' -> do l <- getExpressionHelper True (n + 1)+ return (c : l)+ '{' -> do l <- getExpressionHelper True (n + 1)+ return (c : l)+ ')' -> do l <- getExpressionHelper True (n - 1)+ return (c : l)+ '>' -> do l <- getExpressionHelper True (n - 1)+ return (c : l)+ ']' -> do l <- getExpressionHelper True (n - 1)+ return (c : l)+ '}' -> do l <- getExpressionHelper True (n - 1)+ return (c : l)+ '\n' -> if n > 0+ then do l <- getExpressionHelper b n+ return (c : l)+ else if b+ then return "\n"+ else getExpressionHelper b n+ ' ' -> do l <- getExpressionHelper b n+ return (c : l)+ '\t' -> do l <- getExpressionHelper b n+ return (c : l)+ _ -> do l <- getExpressionHelper True n return (c : l)- '\n' -> if n > 0- then do l <- getExpressionHelper n- return (c : l)- else return "\n"- _ -> do l <- getExpressionHelper n- return (c : l) type IOThrowsError = ErrorT EgiError IO data EgiError = Parser ParseError | NotFunction String- | UnboundVariable String String+ | UnboundVariable String | Default String showError :: EgiError -> String showError (Parser parseErr) = "Parse error at " ++ show parseErr showError (NotFunction str) = "Error : " ++ str-showError (UnboundVariable str name) = "Error : " ++ str ++ name+showError (UnboundVariable name) = "Error : unbound variable" ++ name showError (Default str) = "Error : " ++ str instance Show EgiError where show = showError@@ -124,6 +117,19 @@ extractValue :: ThrowsError a -> a extractValue (Right val) = val +executeTopExpression :: Definitions -> TopExpression -> IOThrowsError String+executeTopExpression defs (Define name expr) = do+ liftIO (modifyIORef defs (\ls -> ((name, expr) : ls)))+ return name+executeTopExpression defs (Test expr) = do+ topFrame <- makeTopFrame defs+ val <- eval (Environment [topFrame]) expr+ liftIO (showValue val)+executeTopExpression defs Execute = do+ topFrame <- makeTopFrame defs+ val <- eval (Environment [topFrame]) (ApplyExp (SymbolExp "main") (TupleExp []))+ liftIO (showValue val)+ -- -- Data Types --@@ -134,7 +140,7 @@ data Expression = CharacterExp Char | StringExp String- | NumberExp Integer+ | IntegerExp Integer | DoubleExp Double | SymbolExp String | InductiveDataExp String [Expression]@@ -186,9 +192,9 @@ data IntermidiateValue = Closure Environment Expression | Value Value -data Value = World+data Value = World [Action] | Character Char- | Number Integer+ | Integer Integer | Double Double | InductiveData String [IORef IntermidiateValue] | Tuple [IORef IntermidiateValue]@@ -200,6 +206,11 @@ | DeconstructorFunction DeconsInfo | BuiltinFunction ([Value] -> IOThrowsError Value) +data Action = Read Value+ | Write Value+ | Memorize Value+ | Remember Value+ data InnerValue = Element (IORef IntermidiateValue) | SubCollection (IORef IntermidiateValue) @@ -223,6 +234,10 @@ stringLiteral = P.stringLiteral lexer integer = P.integer lexer float = P.float lexer+parens = P.parens lexer+angles = P.angles lexer+brackets = P.brackets lexer+braces = P.braces lexer headSymbol :: Parser Char headSymbol = oneOf ":+-*/="@@ -238,32 +253,25 @@ spaces :: Parser () spaces = skipMany (oneOf " \n\t") +spaces1 :: Parser ()+spaces1 = skipMany1 (oneOf " \n\t")+ parseTopExpression :: Parser TopExpression-parseTopExpression = try (do char '('- spaces- string "define"- spaces- char '$'- name <- word- spaces- expr <- parseExpression- spaces- char ')'- return (Define name expr))- <|> try (do char '('- spaces- string "test"- spaces- expr <- parseExpression- spaces- char ')'- return (Test expr))- <|> try (do char '('- spaces- string "execute"- spaces- char ')'- return Execute)+parseTopExpression = do spaces+ parens (do try (string "define")+ spaces+ char '$'+ name <- word+ spaces+ expr <- parseExpression+ return (Define name expr)+ <|> do try (string "test")+ spaces+ expr <- parseExpression+ spaces+ return (Test expr)+ <|> do try (string "execute")+ return Execute) <?> "top expression" parseExpression :: Parser Expression parseExpression = do ws <- word@@ -272,119 +280,73 @@ return (CharacterExp c) <|> do str <- stringLiteral return (StringExp str)- <|> do n <- integer- return (NumberExp n)--- <|> try (do d <- float--- return (DoubleExp d))- <|> do char '<'- spaces- c <- word- spaces- vs <- sepEndBy parseExpression spaces- char '>'- return (InductiveDataExp c vs)- <|> do char '['- spaces- vs <- sepEndBy parseExpression spaces- char ']'- return (TupleExp vs)- <|> do char '{'- spaces- vs <- sepEndBy parseInnerExp spaces- char '}'- return (CollectionExp vs)+ <|> do d <- try float+ return (DoubleExp d)+ <|> do n <- try integer+ return (IntegerExp n)+ <|> angles (do c <- word+ spaces+ vs <- sepEndBy parseExpression spaces+ return (InductiveDataExp c vs))+ <|> brackets (do vs <- sepEndBy parseExpression spaces+ return (TupleExp vs))+ <|> braces (do vs <- sepEndBy parseInnerExp spaces+ return (CollectionExp vs)) <|> try (do pat <- parsePatternExp return (PatternExp pat))- <|> try (do char '('- spaces- string "lambda"- spaces- args <- parseFunPat- spaces- body <- parseExpression- spaces- char ')'- return (FunctionExp args body))- <|> try (do char '('- spaces- string "let"- spaces- bind <- parseBind- spaces- body <- parseExpression- spaces- char ')'- return (LetExp bind body))- <|> try (do char '('- spaces- string "type"- spaces- bind <- parseBind- spaces- char ')'- return (TypeExp bind))- <|> try (do char '('- spaces- string "type-ref"- spaces- typ <- parseExpression- spaces- name <- word- spaces- char ')'- return (TypeRefExp typ name))- <|> try (do char '('- spaces- string "deconstructor"- spaces- deconsInfo <- parseDeconsInfoExp- spaces- char ')'- return (DeconstructorExp deconsInfo))- <|> try (do char '('- spaces- string "match"- spaces- tgt <- parseExpression- spaces- typ <- parseExpression- spaces- char '{'- spaces- clss <- sepEndBy parseMatchClause spaces- char '}'- spaces- char ')'- return (MatchExp tgt typ clss))- <|> try (do char '('- spaces- string "match-map"- spaces- tgt <- parseExpression- spaces- typ <- parseExpression- spaces- cls <- parseMatchClause- spaces- char ')'- return (MatchMapExp tgt typ cls))- <|> try (do char '('- spaces- string "apply"- spaces- fn <- parseExpression- spaces- args <- parseExpression- spaces- char ')'- return (ApplyExp fn args))- <|> do char '('- spaces- fn <- parseExpression- spaces- args <- sepEndBy parseExpression spaces- char ')'- return (ApplyExp fn (TupleExp args))+ <|> parens (do try (do string "lambda"+ spaces1)+ args <- parseFunPat+ spaces+ body <- parseExpression+ return (FunctionExp args body)+ <|> do try (do string "let"+ spaces1)+ bind <- parseBind+ spaces+ body <- parseExpression+ return (LetExp bind body)+ <|> do try (do string "type"+ spaces1)+ bind <- parseBind+ return (TypeExp bind)+ <|> do try (do string "type-ref"+ spaces1)+ typ <- parseExpression+ spaces+ name <- word+ return (TypeRefExp typ name)+ <|> do try (do string "deconstructor"+ spaces1)+ deconsInfo <- parseDeconsInfoExp+ return (DeconstructorExp deconsInfo)+ <|> do try (do string "match"+ spaces1)+ tgt <- parseExpression+ spaces+ typ <- parseExpression+ spaces+ clss <- braces (sepEndBy parseMatchClause spaces)+ return (MatchExp tgt typ clss)+ <|> do try (do string "match-map"+ spaces1)+ tgt <- parseExpression+ spaces+ typ <- parseExpression+ spaces+ cls <- parseMatchClause+ spaces+ return (MatchMapExp tgt typ cls)+ <|> do try (do string "apply"+ spaces1)+ fn <- parseExpression+ spaces+ args <- parseExpression+ return (ApplyExp fn args)+ <|> do fn <- parseExpression+ spaces+ args <- sepEndBy parseExpression spaces+ return (ApplyExp fn (TupleExp args))) parseInnerExp :: Parser InnerExp parseInnerExp = do v <- parseExpression@@ -397,66 +359,36 @@ parseFunPat = do char '$' name <- word return (FunPatVar name)- <|> try (do char '['- spaces- fpat <- parseFunPat- spaces- char ']'- return fpat)- <|> try (do char '['- spaces- fpats <- sepEndBy parseFunPat spaces- char ']'- return (FunPatTuple fpats))+ <|> brackets (do fpats <- (try (sepEndBy parseFunPat spaces))+ case fpats of+ [fpat] -> return fpat+ _ -> return (FunPatTuple fpats)) parseBind :: Parser Bind-parseBind = do char '{'- spaces- bs <- sepEndBy (do char '['- spaces- char '$'- var <- word- spaces- expr <- parseExpression- spaces- char ']'- return (var, expr))- spaces- char '}'- return bs+parseBind = braces (do bs <- sepEndBy (brackets (do char '$'+ var <- word+ spaces+ expr <- parseExpression+ return (var, expr)))+ spaces+ return bs) parseDeconsInfoExp :: Parser DeconsInfoExp-parseDeconsInfoExp = do char '{'- spaces- deconsInfoExp <- sepEndBy parseDeconsClause spaces- spaces- char '}'- return deconsInfoExp+parseDeconsInfoExp = braces (sepEndBy parseDeconsClause spaces) parseDeconsClause :: Parser (String, Expression, [(PrimePat, Expression)]) -parseDeconsClause = do char '['- spaces- patCons <- word- spaces- typExpr <- parseExpression- spaces- char '{'- spaces- dc2s <- sepEndBy parseDeconsClause2 spaces- char '}'- spaces- char ']'- return (patCons, typExpr, dc2s)+parseDeconsClause = brackets (do patCons <- word+ spaces+ typExpr <- parseExpression+ spaces+ dc2s <- braces (sepEndBy parseDeconsClause2 spaces)+ return (patCons, typExpr, dc2s)) parseDeconsClause2 :: Parser (PrimePat, Expression)-parseDeconsClause2 = do char '['- spaces- datPat <- parsePrimePat- spaces- expr <- parseExpression - spaces- char ']'- return (datPat, expr)+parseDeconsClause2 = brackets (do datPat <- parsePrimePat+ spaces+ expr <- parseExpression + return (datPat, expr)) parsePrimePat :: Parser PrimePat parsePrimePat = do char '_'@@ -464,13 +396,10 @@ <|> do char '$' name <- word return (PrimePatVar name)- <|> do char '<'- spaces- c <- word- spaces- ps <- sepEndBy parsePrimePat spaces- char '>'- return (InductivePrimePat c ps)+ <|> angles (do c <- word+ spaces+ ps <- sepEndBy parsePrimePat spaces+ return (InductivePrimePat c ps)) <|> try (do char '{' spaces char '}'@@ -481,7 +410,6 @@ spaces char '.' b <- parsePrimePat- spaces char '}' return (ConsPat a b)) <|> try (do char '{'@@ -490,19 +418,14 @@ a <- parsePrimePat spaces b <- parsePrimePat- spaces char '}' return (SnocPat a b)) parseMatchClause :: Parser MatchClause-parseMatchClause = do char '['- spaces- pat <- parseExpression- spaces- body <- parseExpression- spaces- char ']'- return (MatchClause pat body)+parseMatchClause = brackets (do pat <- parseExpression+ spaces+ body <- parseExpression+ return (MatchClause pat body)) parsePatternExp :: Parser PatternExp parsePatternExp = do char '_'@@ -516,49 +439,26 @@ <|> do char ',' expr <- parseExpression return (ValPatExp expr)- <|> try (do char '('- spaces- string "as"- spaces- char '$'- name <- word- spaces- expr <- parseExpression- spaces- char ')'- return (AsPatExp name expr))- <|> try (do char '('- spaces- string "of"- spaces- expr <- parseExpression- spaces- char '}'- return (OfPatExp expr))- <|> try (do char '('- spaces- string "on"- spaces- var <- (char '$' >> word)- spaces- expr <- parseExpression- spaces- char ')'- return (OnPatExp [var] expr))- <|> try (do char '('- spaces- string "on"- spaces- char '['- spaces- vars <- sepEndBy (char '$' >> word) spaces- char ']'- spaces- expr <- parseExpression- spaces- char ')'- return (OnPatExp vars expr))- + <|> parens (do try (do string "as"+ spaces1)+ char '$'+ name <- word+ spaces+ expr <- parseExpression+ return (AsPatExp name expr)+ <|> do try (do string "of"+ spaces1)+ expr <- parseExpression+ return (OfPatExp expr)+ <|> do try (do string "on"+ spaces1)+ vars <- try (do var <- (char '$' >> word)+ return [var]+ <|> brackets (sepEndBy (char '$' >> word) spaces))+ spaces+ expr <- parseExpression+ return (OnPatExp vars expr))+ -- -- Environment --@@ -569,13 +469,13 @@ then Just iValRef else getValueFromFrame (Frame rest) name -getValue :: Environment -> String -> IOThrowsError (IORef IntermidiateValue)-getValue (Environment []) name = throwError (UnboundVariable "Unbound Variable : " name)+getValue :: Environment -> String -> Maybe (IORef IntermidiateValue)+getValue (Environment []) name = Nothing getValue (Environment (frame : env)) name = let mValRef = getValueFromFrame frame name in case mValRef of Nothing -> getValue (Environment env) name- Just iValRef -> return iValRef+ Just iValRef -> Just iValRef makeClosure :: Environment -> Expression -> IO (IORef IntermidiateValue) makeClosure env expr = newIORef (Closure env expr)@@ -662,12 +562,39 @@ addFrame frame (Environment frames) = Environment (frame:frames) -----+-- read and show Value -- +readValue :: String -> IOThrowsError Value+readValue = undefined+--readValue = readOrThrow parseValue++--getValue :: IO String+--getValue = getExpressionHelper False 0++parseValue :: Parser Value+parseValue = do c <- charLiteral+ return (Character c)+-- <|> do str <- stringLiteral+-- return (String str)+ <|> do d <- try float+ return (Double d)+ <|> do n <- try integer+ return (Integer n)+-- <|> angles (do c <- word+-- spaces+-- vs <- sepEndBy parseValue spaces+-- return (InductiveData c vs))+-- <|> brackets (do vs <- sepEndBy parseValue spaces+-- return (Tuple vs))+-- <|> braces (do vs <- sepEndBy parseInnerValue spaces+-- return (Collection vs))+-- <|> try (do pat <- parsePatternValue+-- return (Pattern pat))+ showValue :: Value -> IO String showValue (Character c) = return (show c)-showValue (Number n) = return (show n)+showValue (Integer n) = return (show n) showValue (Double d) = return (show d) showValue (InductiveData cons []) = do return ("<" ++ cons ++ ">")@@ -701,7 +628,11 @@ showPattern :: Pattern -> IO String showPattern WildCard = return "_" showPattern (PatVar name) = return ("$" ++ name)-showPattern _ = undefined+showPattern (CutPat _) = return "#<cut-pat>"+showPattern (AsPat _ _) = return "#<as-pat>"+showPattern (OfPat _) = return "#<of-pat>"+showPattern (OnPat _ _ _) = return "#<on-pat>"+showPattern (ValPat _) = return "#<val-pat>" unwordsList :: Show a => [a] -> String unwordsList = unwords . map show@@ -738,15 +669,16 @@ eval1 _ (StringExp str) = do val <- liftIO (makeCollectionFromValueList (map Character str)) return val-eval1 _ (NumberExp n) = return (Number n)+eval1 _ (IntegerExp n) = return (Integer n) eval1 _ (DoubleExp d) = return (Double d)-eval1 env (SymbolExp name) = do- let mBuiltinFn = getBuiltin name in- case mBuiltinFn of- Just builtinFn -> return (BuiltinFunction builtinFn)- Nothing -> do iValRef <- getValue env name- val <- force iValRef- return val+eval1 env (SymbolExp name) =+ let mIValRef = getValue env name in+ case mIValRef of+ Just iValRef -> force iValRef+ Nothing -> let mBuiltinFn = getBuiltin name in+ case mBuiltinFn of+ Just builtinFn -> return (BuiltinFunction builtinFn)+ Nothing -> throwError (UnboundVariable name) eval1 env (InductiveDataExp con exprs) = do iValRefs <- liftIO (makeClosureList env exprs) return (InductiveData con iValRefs)@@ -1150,7 +1082,19 @@ Value val -> do vals <- tupleToValueList (Tuple iValRefs) return (val:vals) tupleToValueList val = return [val] - ++makeTupleFromValueList :: [Value] -> IO Value+makeTupleFromValueList vals = do+ iValRefs <- makeIValRefList vals+ return (Tuple iValRefs)++makeIValRefList :: [Value] -> IO [IORef IntermidiateValue]+makeIValRefList [] = return []+makeIValRefList (val:vals) = do+ iValRef <- newIORef (Value val)+ iValRefs <- makeIValRefList vals+ return (iValRef:iValRefs)+ collectionToList :: (IORef IntermidiateValue) -> IOThrowsError [IORef IntermidiateValue] collectionToList iValRef = do val <- force iValRef@@ -1195,21 +1139,54 @@ getBuiltin :: String -> Maybe ([Value] -> IOThrowsError Value) getBuiltin name = case name of+ "read" -> Just builtinRead+ "write" -> Just builtinWrite+ "read-char" -> Just builtinReadChar+ "write-char" -> Just builtinWriteChar "+" -> Just builtinPlus "-" -> Just builtinMinus "*" -> Just builtinMultiply _ -> Nothing++builtinRead :: [Value] -> IOThrowsError Value+--builtinRead [(World actions)] = do+-- str <- getExpression+-- val <- readValue str+-- ret <- liftIO (makeTupleFromValueList [World ((Read val):actions), val])+-- return ret+builtinRead _ = throwError (Default "invalid args to read") +builtinWrite :: [Value] -> IOThrowsError Value+builtinWrite [(World actions), val] = do+ valStr <- liftIO (showValue val)+ liftIO (flushStr valStr)+ return (World ((Write val):actions))+builtinWrite _ = throwError (Default "invalid args to write")+ +builtinReadChar :: [Value] -> IOThrowsError Value+builtinReadChar [(World actions)] = do+ undefined+builtinReadChar _ = throwError (Default "invalid args to read-char")++builtinWriteChar :: [Value] -> IOThrowsError Value+builtinWriteChar [(World actions), (Character c)] = do+ liftIO (putChar c)+ return (World ((Write (Character c)):actions))+builtinWriteChar _ = throwError (Default "invalid args to write-char")+ builtinPlus :: [Value] -> IOThrowsError Value-builtinPlus [(Number n1), (Number n2)] = return (Number (n1 + n2))+builtinPlus [(Integer n1), (Integer n2)] = return (Integer (n1 + n2))+builtinPlus [(Double n1), (Double n2)] = return (Double (n1 + n2)) builtinPlus _ = throwError (Default "invalid args to +") builtinMinus :: [Value] -> IOThrowsError Value-builtinMinus [(Number n1), (Number n2)] = return (Number (n1 - n2))+builtinMinus [(Integer n1), (Integer n2)] = return (Integer (n1 - n2))+builtinMinus [(Double n1), (Double n2)] = return (Double (n1 - n2)) builtinMinus _ = throwError (Default "invalid args to -") builtinMultiply :: [Value] -> IOThrowsError Value-builtinMultiply [(Number n1), (Number n2)] = return (Number (n1 * n2))+builtinMultiply [(Integer n1), (Integer n2)] = return (Integer (n1 * n2))+builtinMultiply [(Double n1), (Double n2)] = return (Double (n1 * n2)) builtinMultiply _ = throwError (Default "invalid args to *") ---@@ -1225,7 +1202,7 @@ showExpression :: Expression -> String showExpression (CharacterExp c) = show c-showExpression (NumberExp n) = show n+showExpression (IntegerExp n) = show n showExpression (SymbolExp name) = name showExpression (InductiveDataExp s []) = "<" ++ s ++ ">" showExpression (InductiveDataExp s vs) = "<" ++ s ++ " " ++ unwordsList vs ++ ">"
egison.cabal view
@@ -7,16 +7,16 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.1+Version: 0.1.1 -- A short (one-line) description of the package.-Synopsis: Programming Language Egison+Synopsis: An Interpreter for the Programming Language Egison -- A longer description of the package.-Description: Feature of this programming language is the strong- pattern match facility. This package include sample Egison programming- codes "*-test.egi" in "sample/" directory. You can download ELisp file- "egison-mode.el" from the home page of Egison.+Description: An interpreter for the programming language Egison.+ A eature of Egison is the strong pattern match facility.+ This package include sample Egison program codes "*-test.egi" in "etc/sample/" directory.+ This package also include Emacs Lisp file "egison-mode.el" in "etc/elisp/" directory. -- URL for the project homepage or repository. Homepage: http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/@@ -41,16 +41,16 @@ Build-type: Simple -Data-Dir: sample+Data-Dir: etc/ -Data-files: nat-test.egi list-test.egi+Data-files: sample/nat-test.egi sample/list-test.egi elisp/egison-mode.el -- Extra files to be distributed with the package, such as examples or -- a README. -- Extra-source-files: -- Constraint on the version of Cabal needed to build this package.-Cabal-version: >=1.4+Cabal-version: >=1.6 Executable egison@@ -65,4 +65,7 @@ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: - ++Source-Repository head+ type: git+ location: https://github.com/egisatoshi/egison
+ etc/elisp/egison-mode.el view
@@ -0,0 +1,153 @@+;;; egison-mode.el --- Egison editing mode++(defconst egison-font-lock-keywords-1+ (eval-when-compile+ (list+ "\\<define\\>"+ "\\<test\\>"+ "\\<execute\\>"+ + "\\<lambda\\>"+ "\\<let\\>"+ "\\<type\\>"+ "\\<type-ref\\>"+ "\\<deconstructor\\>"+ "\\<match\\>"+ "\\<match-map\\>"++ "\\\."+ "\\\,"+ "\\\!"+ "@"+ "\\<_\\>"+ "\\<on\\>"+ "\\<as\\>"+ "\\<of\\>"+ ))+ "Subdued expressions to highlight in Egison modes.")++(defconst egison-font-lock-keywords-2+ (append egison-font-lock-keywords-1+ (eval-when-compile+ (list+ (cons "\\\$\\\w*" font-lock-variable-name-face)+ )))+ "Gaudy expressions to highlight in Egison modes.")++(defvar egison-font-lock-keywords egison-font-lock-keywords-1+ "Default expressions to highlight in Egison modes.")+++(defun open-paren-p ()+ (let ((c (string-to-char (thing-at-point 'char))))+ (or (eq c 40) (eq c 60) (eq c 91) (eq c 123))))++(defun close-paren-p ()+ (let ((c (string-to-char (thing-at-point 'char))))+ (or (eq c 41) (eq c 62) (eq c 93) (eq c 125))))++(defun last-unclosed-paren ()+ (save-excursion+ (let ((pc 0))+ (while (<= pc 0)+ (if (bobp)+ (setq pc 2)+ (backward-char)+ (if (open-paren-p)+ (setq pc (+ pc 1))+ (if (close-paren-p)+ (setq pc (- pc 1))))))+ (if (= pc 2)+ nil+ (point)))))++(defun indent-point ()+ (save-excursion+ (beginning-of-line)+ (let ((p (last-unclosed-paren)))+ (if p+ (progn+ (goto-char (last-unclosed-paren))+ (let ((cp (current-column)))+ (cond ((eq (string-to-char (thing-at-point 'char)) 40)+ (forward-char)+ (let* ((op (current-word))+ (ip (keyword-indent-point op)))+ (if ip+ (+ ip cp)+ (+ 2 (length op) cp))))+ ((eq (string-to-char (thing-at-point 'char)) 60)+ (forward-char)+ (let ((op (current-word)))+ (+ 2 (length op) cp)))+ (t (+ 1 cp)))))+ 0))))++(defun keyword-indent-point (name)+ (cond ((equal "define" name) 2)+ ((equal "lambda" name) 2)+ ((equal "let" name) 2)+ ((equal "match" name) 2)+ ((equal "match-map" name) 2)+ ((equal "type" name) 2)+ ((equal "deconstructor" name) 2)+ ))++(defun egison-indent-line ()+ "indent current line as Egison code."+ (interactive)+ (indent-line-to (indent-point)))+++(defvar egison-mode-map+ (let ((smap (make-sparse-keymap)))+ (define-key smap "\C-j" 'newline-and-indent)+ smap)+ "Keymap for Egison mode.")+++(defvar egison-mode-syntax-table+ (let ((egison-mode-syntax-table (make-syntax-table)))+ (modify-syntax-entry 60 "(" egison-mode-syntax-table)+ (modify-syntax-entry 62 ")" egison-mode-syntax-table)+ egison-mode-syntax-table)+ "Syntax table for Egison mode")++(defun egison-mode-variables ()+ (set-syntax-table egison-mode-syntax-table)+ (set (make-local-variable 'font-lock-defaults)+ '((egison-font-lock-keywords+ egison-font-lock-keywords-1 egison-font-lock-keywords-2)+ nil t (("+-*/=?%:_" . "w") ("<" . "(") (">" . ")"))+ ))+ (set (make-local-variable 'indent-line-function)+ 'egison-indent-line)+ )+++(defun egison-mode ()+ "Major mode for editing Egison code.++Commands:+\\{egison-mode-map}+Entry to this mode calls the value of `egison-mode-hook'+if that value is non-nil."+ (interactive)+ (kill-all-local-variables)+ (use-local-map egison-mode-map)+ (setq major-mode 'egison-mode)+ (setq mode-name "Egison")+ (egison-mode-variables)+ (run-mode-hooks 'egison-mode-hook))+++(defgroup egison nil+ "Editing Egison code."+ :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)+ :group 'lisp)++(defcustom egison-mode-hook nil+ "Normal hook run when entering `egison-mode'.+See `run-hooks'."+ :type 'hook+ :group 'egison)
+ etc/sample/list-test.egi view
@@ -0,0 +1,429 @@+(define $Something+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ }))++(define $Suit+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[spade []+ {[<spade> {[]}]+ [_ {}]}]+ [heart []+ {[<heart> {[]}]+ [_ {}]}]+ [club []+ {[<club> {[]}]+ [_ {}]}]+ [diamond []+ {[<diamond> {[]}]+ [_ {}]}]+ })]+ [$=+ (lambda [$val $tgt]+ (match [val tgt] [Card Card]+ {[[<spade> <spade>] <true>]+ [[<heart> <heart>] <true>]+ [[<club> <club>] <true>]+ [[<diamond> <diamond>] <true>]+ [[_ _] <false>]}))]+ }))++(test (match-map <club> Suit [<club> <ok>]))++(define $Nat+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[o []+ {[<o> {[]}]+ [_ {}]+ }]+ [s [Nat]+ {[<s $x> {x}]+ [_ {}]+ }]+ })]+ [$=+ (lambda [$val $tgt]+ (match [val tgt] [Nat Nat]+ {[[<o> <o>] <true>]+ [[<s $n1> <s $n2>] (= n1 n2)]+ [[_ _] <false>]}))]+ }))++(define $monus+ (lambda [$m $n]+ (match [m n] [Nat Nat]+ {[[_ <o>] m]+ [[<o> _] <o>]+ [[<s $m1> <s $n1>] (monus m1 n1)]})))++(test (monus <s <s <o>>> <s <o>>))++(define $mod+ (lambda [$m $n]+ (match (monus m n) Nat+ {[<o> m]+ [$m1 (mod m1 n)]})))++(test (mod <s <s <s <s <o>>>>> <s <s <s <o>>>>))++(define $Mod+ (lambda [$m]+ (let {[$Loop+ (type {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[o []+ {[<o> {[]}]+ [_ {}]+ }]+ [s [Loop]+ {[<s $x> {x}]+ [<o> {m}]+ }]})]+ [$= (lambda [$val $tgt]+ ((type-ref Nat =) (mod val m) tgt))]})]}+ (type+ {[$var-match (lambda [$tgt] {(mod tgt m)})]+ [$inductive-match+ (lambda [$tgt]+ ((type-ref Loop inductive-match) (mod tgt m)))]+ [$= (lambda [$val $tgt]+ ((type-ref Nat =) (mod val m) (mod tgt m)))]}))))++(test (match <s <s <s <s <o>>>>> (Mod <s <s <s <o>>>>)+ {[<o> <not-ok>]+ [<s <o>> <ok>]+ [<s <s <o>>> <not-ok>]}))++(define $List+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[nil []+ {[{} {[]}]+ [_ {}]+ }]+ [cons [a (List a)]+ {[{$x .$xs} {[x xs]}]+ [_ {}]+ }]+ [snoc [a (List a)]+ {[{.$xs $x} {[x xs]}]+ [_ {}]+ }]+ [join [(List a) (List a)]+ {[$tgt (let {[$loop+ (lambda [$ts]+ (match ts (List a)+ {[<nil> {[{} {}]}]+ [<cons $x $xs>+ {[{} ts]+ @(map (lambda [$as $bs]+ [{x @as} bs])+ (loop xs))}]}))]}+ (loop tgt))]+ }]+ [nioj [(List a) (List a)]+ {[$tgt (let {[$loop+ (lambda [$ts]+ (match ts (List a)+ {[<nil> {[{} {}]}]+ [<snoc $x $xs>+ {[{} ts]+ @(map (lambda [$as $bs]+ [{@as x} bs])+ (loop xs))}]}))]}+ (loop tgt))]+ }]+ })]+ [$= (lambda [$val $tgt]+ (match [val tgt] [(List a) (List a)]+ {[[<nil> <nil>] <true>]+ [[<cons $x $xs>+ <cons (on [$x] ,x) (on [$xs] ,xs)>]+ <true>]+ [[_ _] <false>]}))]+ })))++(test ((type-ref (List Nat) =) {<o> <s <o>>} {<o> <s <o>>}))++(test (match-map {<o> <s <o>> <s <s <o>>>} (List Nat) [<snoc $x $xs> [x xs]]))++(test (match-map {<o> <s <o>> <s <s <o>>>} (List Nat) [<nioj $xs $ys> [xs ys]]))++(define $map+ (lambda [$fn $ls]+ (match ls (List Something)+ {[<nil> {}]+ [<cons $x $xs> {(fn x) @(map fn xs)}]})))++(test (map (lambda [$a] <s a>) {<o> <s <o>>}))++(test (match {} (List Something)+ {[<join $hs $ts> [hs ts]]}))++(test (match-map {<x> <y>} (List Something)+ [<join $hs $ts> [hs ts]]))++(test (match-map {<x> <y> <z> <w>} (List Something)+ [<join $hs <cons $x $ts>> [hs x ts]]))++(define $remove+ (lambda [$a]+ (lambda [$xs $x]+ (match xs (List a)+ {[<nil> {}]+ [<cons x $rs> rs]+ [<cons $y $rs> {y @((remove a) rs x)}]}))))++(test ((remove Nat) {<o> <s <o>>} <o>))++(define $remove-collection+ (lambda [$a]+ (lambda [$xs $ys]+ (match ys (List a)+ {[<nil> xs]+ [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))++(test ((remove-collection Nat) {<o> <s <o>> <s <s <o>>>} {<o> <s <s <o>>>}))++(define $subcollection+ (lambda [$xs]+ (match xs (List Something)+ {[<nil> {{}}]+ [<cons $x $rs>+ (let {[$subs (subcollection rs)]}+ {@subs @(map (lambda [$sub] {x @sub})+ subs)})]+ })))++(test (subcollection {<o> <s <o>> <s <s <o>>>}))++(define $Multiset+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[nil []+ {[{} {[]}]+ [_ {}]+ }]+ [cons [a (Multiset a)]+ {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])+ tgt)]+ }]+ [join [(Multiset a) (Multiset a)]+ {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])+ (subcollections tgt))]+ }]+ })]+ [$= (lambda [$val $tgt]+ (match [val tgt] [(Multiset a) (Multiset a)]+ {[[<nil> <nil>] <true>]+ [[<cons $x $xs>+ <cons (on [$x] x) (on [$xs] xs)>]+ <true>]+ [[_ _] <false>]}))]+ })))++(define $one-pair+ (lambda [$ns]+ (match ns (Multiset Nat)+ {[<cons $m+ <cons (on [$m] m)+ _>>+ <ok>]+ [_ <nothing>]+ })))++(test (one-pair {<o> <s <o>> <o>}))++(define $full-house+ (lambda [$ns]+ (match ns (Multiset Nat)+ {[<cons $m+ <cons (on [$m] m)+ <cons (on [$m] m)+ !<cons $n+ !<cons (on [$n] n)+ !<nil>+ >>>>>+ <full-house>]+ [_ <nothing>]+ })))++(test (full-house {<o> <o> <s <o>> <o> <s <o>>}))++(define $thirteen <s <s <s <s <s <s <s <s <s <s <s <s <s <o>>>>>>>>>>>>>>)++(define $Card+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[card [Suit (Mod thirteen)]+ {[<card $s $n> {[s n]}]}]})]+ [$= <undefined>]}))++(define $poker-hands+ (lambda [$Cs]+ (match Cs (Multiset Card)+ {[<cons <card $S $n>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 1))>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 2))>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 3))>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 4))>+ !<nil>+ >>>>>+ <straight-flush>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <four-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ !<cons <card _ (on [$n] ,n)>+ !<nil>+ >>>>>+ <full-house>]+ [<cons <card $S _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<nil>+ >>>>>+ <flush>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,(- n 1))>+ <cons <card _ (on [$n] ,(- n 2))>+ <cons <card _ (on [$n] ,(- n 3))>+ <cons <card _ (on [$n] ,(- n 4))>+ !<nil>+ >>>>>+ <straight>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <three-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <two-pair>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <one-pair>]+ [<cons _+ !<cons _+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <nothing>]})))++(define $poker-hands-without-strait+ (lambda [$Cs]+ (match Cs (Multiset Card)+ {[<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <four-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ !<cons <card _ (on [$n] ,n)>+ !<nil>+ >>>>>+ <full-house>]+ [<cons <card $S _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<nil>+ >>>>>+ <flush>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <three-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <two-pair>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <one-pair>]+ [<cons _+ !<cons _+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <nothing>]})))++(test (poker-hands-without-strait {<card <diamond> <o>>+ <card <club> <s <o>>>+ <card <club> <o>>+ <card <heart> <o>>+ <card <diamond> <s <o>>>}))++(define $car+ (lambda [$as]+ (match as (List Something)+ {[<cons $a _> a]})))++(define $reverse+ (lambda [$as]+ (match as (List Something)+ {[<nil> {}]+ [<cons $a $rs>+ {@(reverse rs) a}]})))
+ etc/sample/nat-test.egi view
@@ -0,0 +1,78 @@+(define $Nat+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[o []+ {[<o> {[]}] + [_ {}]+ }]+ [s [Nat]+ {[<s $x> {x}]+ [_ {}]+ }]+ })]+ [$=+ (lambda [$val $tgt]+ (match [val tgt] [Nat Nat]+ {[[<o> <o>] <true>]+ [[<s $n1> <s $n2>] (= n1 n2)]+ [[_ _] <false>]}))]+ }))++(test ((type-ref Nat =) <o> <o>))++(define $++ (lambda [$m $n]+ (match m Nat+ {[<o> n]+ [<s $m1> <s (+ m1 n)>]})))++(define $*+ (lambda [$m $n]+ (match m Nat+ {[<o> <o>]+ [<s <o>> n]+ [<s $m1> (+ n (* m1 n))]})))+ +(define $fact+ (lambda [$n]+ (match n Nat+ {[<o> <s <o>>]+ [<s $n1> (* n (fact n1))]})))++(test (fact <s <s <s <o>>>>))++(define $fib+ (lambda [$n]+ (match n Nat+ {[<o> <s <o>>]+ [<s <o>> <s <o>>]+ [<s <s $n1>> (+ (fib <s n1>) (fib n1))]})))++(test (fib <s <s <s <s <s <s <o>>>>>>>))++(define $val-match-test+ (lambda [$n]+ (match n Nat+ {[,(+ <s <o>> <s <s <o>>>) <ok>]+ [$n1 n1]})))++(test (val-match-test <s <s <s <o>>>>))++(define $on-pat-test+ (lambda [$m $n]+ (match [m n] [Nat Nat]+ {[[$m1 (on [$m1] <s m1>)] m1]+ [[_ _] <not-ok>]})))++(test (on-pat-test <o> <s <o>>))++(define $on-pat-test2+ (lambda [$m $n]+ (match [m n] [Nat Nat]+ {[[$m1 <s (on [$m1] m1)>] m1]+ [[_ _] <not-ok>]})))++(test (on-pat-test2 <o> <s <o>>))+
− sample/list-test.egi
@@ -1,429 +0,0 @@-(define $Something- (type- {[$var-match (lambda [$tgt] {tgt})]- }))--(define $Suit- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[spade []- {[<spade> {[]}]- [_ {}]}]- [heart []- {[<heart> {[]}]- [_ {}]}]- [club []- {[<club> {[]}]- [_ {}]}]- [diamond []- {[<diamond> {[]}]- [_ {}]}]- })]- [$=- (lambda [$val $tgt]- (match [val tgt] [Card Card]- {[[<spade> <spade>] <true>]- [[<heart> <heart>] <true>]- [[<club> <club>] <true>]- [[<diamond> <diamond>] <true>]- [[_ _] <false>]}))]- }))--(test (match-map <club> Suit [<club> <ok>]))--(define $Nat- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[o []- {[<o> {[]}]- [_ {}]- }]- [s [Nat]- {[<s $x> {x}]- [_ {}]- }]- })]- [$=- (lambda [$val $tgt]- (match [val tgt] [Nat Nat]- {[[<o> <o>] <true>]- [[<s $n1> <s $n2>] (= n1 n2)]- [[_ _] <false>]}))]- }))--(define $monus- (lambda [$m $n]- (match [m n] [Nat Nat]- {[[_ <o>] m]- [[<o> _] <o>]- [[<s $m1> <s $n1>] (monus m1 n1)]})))--(test (monus <s <s <o>>> <s <o>>))--(define $mod- (lambda [$m $n]- (match (monus m n) Nat- {[<o> m]- [$m1 (mod m1 n)]})))--(test (mod <s <s <s <s <o>>>>> <s <s <s <o>>>>))--(define $Mod- (lambda [$m]- (let {[$Loop- (type {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[o []- {[<o> {[]}]- [_ {}]- }]- [s [Loop]- {[<s $x> {x}]- [<o> {m}]- }]})]- [$= (lambda [$val $tgt]- ((type-ref Nat =) (mod val m) tgt))]})]}- (type- {[$var-match (lambda [$tgt] {(mod tgt m)})]- [$inductive-match- (lambda [$tgt]- ((type-ref Loop inductive-match) (mod tgt m)))]- [$= (lambda [$val $tgt]- ((type-ref Nat =) (mod val m) (mod tgt m)))]}))))--(test (match <s <s <s <s <o>>>>> (Mod <s <s <s <o>>>>)- {[<o> <not-ok>]- [<s <o>> <ok>]- [<s <s <o>>> <not-ok>]}))--(define $List- (lambda [$a]- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[nil []- {[{} {[]}]- [_ {}]- }]- [cons [a (List a)]- {[{$x .$xs} {[x xs]}]- [_ {}]- }]- [snoc [a (List a)]- {[{.$xs $x} {[x xs]}]- [_ {}]- }]- [join [(List a) (List a)]- {[$tgt (let {[$loop- (lambda [$ts]- (match ts (List a)- {[<nil> {[{} {}]}]- [<cons $x $xs>- {[{} ts]- @(map (lambda [$as $bs]- [{x @as} bs])- (loop xs))}]}))]}- (loop tgt))]- }]- [nioj [(List a) (List a)]- {[$tgt (let {[$loop- (lambda [$ts]- (match ts (List a)- {[<nil> {[{} {}]}]- [<snoc $x $xs>- {[{} ts]- @(map (lambda [$as $bs]- [{@as x} bs])- (loop xs))}]}))]}- (loop tgt))]- }]- })]- [$= (lambda [$val $tgt]- (match [val tgt] [(List a) (List a)]- {[[<nil> <nil>] <true>]- [[<cons $x $xs>- <cons (on [$x] ,x) (on [$xs] ,xs)>]- <true>]- [[_ _] <false>]}))]- })))--(test ((type-ref (List Nat) =) {<o> <s <o>>} {<o> <s <o>>}))--(test (match-map {<o> <s <o>> <s <s <o>>>} (List Nat) [<snoc $x $xs> [x xs]]))--(test (match-map {<o> <s <o>> <s <s <o>>>} (List Nat) [<nioj $xs $ys> [xs ys]]))--(define $map- (lambda [$fn $ls]- (match ls (List Something)- {[<nil> {}]- [<cons $x $xs> {(fn x) @(map fn xs)}]})))--(test (map (lambda [$a] <s a>) {<o> <s <o>>}))--(test (match {} (List Something)- {[<join $hs $ts> [hs ts]]}))--(test (match-map {<x> <y>} (List Something)- [<join $hs $ts> [hs ts]]))--(test (match-map {<x> <y> <z> <w>} (List Something)- [<join $hs <cons $x $ts>> [hs x ts]]))--(define $remove- (lambda [$a]- (lambda [$xs $x]- (match xs (List a)- {[<nil> {}]- [<cons x $rs> rs]- [<cons $y $rs> {y @((remove a) rs x)}]}))))--(test ((remove Nat) {<o> <s <o>>} <o>))--(define $remove-collection- (lambda [$a]- (lambda [$xs $ys]- (match ys (List a)- {[<nil> xs]- [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))--(test ((remove-collection Nat) {<o> <s <o>> <s <s <o>>>} {<o> <s <s <o>>>}))--(define $subcollection- (lambda [$xs]- (match xs (List Something)- {[<nil> {{}}]- [<cons $x $rs>- (let {[$subs (subcollection rs)]}- {@subs @(map (lambda [$sub] {x @sub})- subs)})]- })))--(test (subcollection {<o> <s <o>> <s <s <o>>>}))--(define $Multiset- (lambda [$a]- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[nil []- {[{} {[]}]- [_ {}]- }]- [cons [a (Multiset a)]- {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])- tgt)]- }]- [join [(Multiset a) (Multiset a)]- {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])- (subcollections tgt))]- }]- })]- [$= (lambda [$val $tgt]- (match [val tgt] [(Multiset a) (Multiset a)]- {[[<nil> <nil>] <true>]- [[<cons $x $xs>- <cons (on [$x] x) (on [$xs] xs)>]- <true>]- [[_ _] <false>]}))]- })))--(define $one-pair- (lambda [$ns]- (match ns (Multiset Nat)- {[<cons $m- <cons (on [$m] m)- _>>- <ok>]- [_ <nothing>]- })))--(test (one-pair {<o> <s <o>> <o>}))--(define $full-house- (lambda [$ns]- (match ns (Multiset Nat)- {[<cons $m- <cons (on [$m] m)- <cons (on [$m] m)- !<cons $n- !<cons (on [$n] n)- !<nil>- >>>>>- <full-house>]- [_ <nothing>]- })))--(test (full-house {<o> <o> <s <o>> <o> <s <o>>}))--(define $thirteen <s <s <s <s <s <s <s <s <s <s <s <s <s <o>>>>>>>>>>>>>>)--(define $Card- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[card [Suit (Mod thirteen)]- {[<card $s $n> {[s n]}]}]})]- [$= <undefined>]}))--(define $poker-hands- (lambda [$Cs]- (match Cs (Multiset Card)- {[<cons <card $S $n>- <cons <card (on [$S] ,S) (on [$n] ,(- n 1))>- <cons <card (on [$S] ,S) (on [$n] ,(- n 2))>- <cons <card (on [$S] ,S) (on [$n] ,(- n 3))>- <cons <card (on [$S] ,S) (on [$n] ,(- n 4))>- !<nil>- >>>>>- <straight-flush>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>- !<cons _- !<nil>- >>>>>- <four-of-kind>]- [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>- <cons <card _ (on [$m] ,m)>- !<cons <card _ $n>- !<cons <card _ (on [$n] ,n)>- !<nil>- >>>>>- <full-house>]- [<cons <card $S _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<nil>- >>>>>- <flush>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,(- n 1))>- <cons <card _ (on [$n] ,(- n 2))>- <cons <card _ (on [$n] ,(- n 3))>- <cons <card _ (on [$n] ,(- n 4))>- !<nil>- >>>>>- <straight>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- <cons <card _ (on [$n] ,n)>- !<cons _- !<cons _- !<nil>- >>>>>- <three-of-kind>]- [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>- !<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons _- !<nil>- >>>>>- <two-pair>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>- <one-pair>]- [<cons _- !<cons _- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>- <nothing>]})))--(define $poker-hands-without-strait- (lambda [$Cs]- (match Cs (Multiset Card)- {[<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>- !<cons _- !<nil>- >>>>>- <four-of-kind>]- [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>- <cons <card _ (on [$m] ,m)>- !<cons <card _ $n>- !<cons <card _ (on [$n] ,n)>- !<nil>- >>>>>- <full-house>]- [<cons <card $S _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<nil>- >>>>>- <flush>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- <cons <card _ (on [$n] ,n)>- !<cons _- !<cons _- !<nil>- >>>>>- <three-of-kind>]- [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>- !<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons _- !<nil>- >>>>>- <two-pair>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>- <one-pair>]- [<cons _- !<cons _- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>- <nothing>]})))--(test (poker-hands-without-strait {<card <diamond> <o>>- <card <club> <s <o>>>- <card <club> <o>>- <card <heart> <o>>- <card <diamond> <s <o>>>}))--(define $car- (lambda [$as]- (match as (List Something)- {[<cons $a _> a]})))--(define $reverse- (lambda [$as]- (match as (List Something)- {[<nil> {}]- [<cons $a $rs>- {@(reverse rs) a}]})))
− sample/nat-test.egi
@@ -1,78 +0,0 @@-(define $Nat- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[o []- {[<o> {[]}]- [_ {}]- }]- [s [Nat]- {[<s $x> {x}]- [_ {}]- }]- })]- [$=- (lambda [$val $tgt]- (match [val tgt] [Nat Nat]- {[[<o> <o>] <true>]- [[<s $n1> <s $n2>] (= n1 n2)]- [[_ _] <false>]}))]- }))--(test ((type-ref Nat =) <o> <o>))--(define $+- (lambda [$m $n]- (match m Nat- {[<o> n]- [<s $m1> <s (+ m1 n)>]})))--(define $*- (lambda [$m $n]- (match m Nat- {[<o> <o>]- [<s <o>> n]- [<s $m1> (+ n (* m1 n))]})))- -(define $fact- (lambda [$n]- (match n Nat- {[<o> <s <o>>]- [<s $n1> (* n (fact n1))]})))--(test (fact <s <s <s <o>>>>))--(define $fib- (lambda [$n]- (match n Nat- {[<o> <s <o>>]- [<s <o>> <s <o>>]- [<s <s $n1>> (+ (fib <s n1>) (fib n1))]})))--(test (fib <s <s <s <s <s <s <o>>>>>>>))--(define $val-match-test- (lambda [$n]- (match n Nat- {[,(+ <s <o>> <s <s <o>>>) <ok>]- [$n1 n1]})))--(test (val-match-test <s <s <s <o>>>>))--(define $on-pat-test- (lambda [$m $n]- (match [m n] [Nat Nat]- {[[$m1 (on [$m1] <s m1>)] m1]- [[_ _] <not-ok>]})))--(test (on-pat-test <o> <s <o>>))--(define $on-pat-test2- (lambda [$m $n]- (match [m n] [Nat Nat]- {[[$m1 <s (on [$m1] m1)>] m1]- [[_ _] <not-ok>]})))--(test (on-pat-test2 <o> <s <o>>))-