diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.10.0 +Version: 3.10.1 Synopsis: Programming language with non-linear pattern-matching against non-free data Description: An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language. diff --git a/hs-src/Interpreter/egison.hs b/hs-src/Interpreter/egison.hs --- a/hs-src/Interpreter/egison.hs +++ b/hs-src/Interpreter/egison.hs @@ -7,7 +7,6 @@ import Control.Exception (AsyncException (..), catch) import Control.Monad.Except import Control.Monad.Trans.State -import Prelude hiding (catch) import qualified Data.Text as T diff --git a/hs-src/Language/Egison/AST.hs b/hs-src/Language/Egison/AST.hs --- a/hs-src/Language/Egison/AST.hs +++ b/hs-src/Language/Egison/AST.hs @@ -18,9 +18,9 @@ , Index (..) , PMMode (..) , InnerExpr (..) - , BindingExpr (..) - , MatchClause (..) - , PatternDef (..) + , BindingExpr + , MatchClause + , PatternDef , LoopRange (..) , PrimitivePatPattern (..) , PrimitiveDataPattern (..) diff --git a/hs-src/Language/Egison/ParserNonS.hs b/hs-src/Language/Egison/ParserNonS.hs --- a/hs-src/Language/Egison/ParserNonS.hs +++ b/hs-src/Language/Egison/ParserNonS.hs @@ -32,7 +32,7 @@ import Control.Monad.State (unless) import Data.Functor (($>)) -import Data.List (find) +import Data.List (find, groupBy) import Data.Maybe (fromJust, isJust) import Data.Text (pack) import Data.Traversable (mapM) @@ -138,8 +138,8 @@ -- topExpr :: Parser EgisonTopExpr -topExpr = Load <$> (keywordLoad >> stringLiteral) - <|> LoadFile <$> (keywordLoadFile >> stringLiteral) +topExpr = Load <$> (reserved "load" >> stringLiteral) + <|> LoadFile <$> (reserved "loadFile" >> stringLiteral) <|> defineOrTestExpr "toplevel expression" @@ -177,7 +177,20 @@ ScalarArg x : xs -> exprToArgs lhs ++ TensorArg x : xs expr :: Parser EgisonExpr -expr = ifExpr +expr = do + body <- exprWithoutWhere + bindings <- optional whereDefs + return $ case bindings of + Nothing -> body + Just bindings -> LetRecExpr bindings body + where + whereDefs = do + pos <- reserved "where" >> L.indentLevel + some (L.indentGuard sc EQ pos >> binding) + +exprWithoutWhere :: Parser EgisonExpr +exprWithoutWhere = + ifExpr <|> patternMatchExpr <|> lambdaExpr <|> letExpr @@ -200,53 +213,46 @@ opExpr = do pos <- L.indentLevel makeExprParser atomOrApplyExpr (makeTable pos) + +makeTable :: Pos -> [[Operator Parser EgisonExpr]] +makeTable pos = + -- prefixes have top priority + let prefixes = [ [ Prefix (unary "-") + , Prefix (unary "!") ] ] + -- Generate binary operator table from reservedBinops + binops = map (map binOpToOperator) + (groupBy (\x y -> priority x == priority y) reservedBinops) + in prefixes ++ binops where - makeTable :: Pos -> [[Operator Parser EgisonExpr]] - makeTable pos = - let unary sym = UnaryOpExpr <$> operator sym - binary sym = do - op <- try (L.indentGuard sc GT pos >> binOpLiteral sym <* notFollowedBy (symbol ")")) - return $ BinaryOpExpr op - in - [ [ Prefix (unary "-" ) - , Prefix (unary "!" ) ] - -- 8 - , [ InfixL (binary "^" ) ] - -- 7 - , [ InfixL (binary "*" ) - , InfixL (binary "/" ) - , InfixL (binary "%" ) ] - -- 6 - , [ InfixL (binary "+" ) - , InfixL (binary "-" ) ] - -- 5 - , [ InfixR (binary "::" ) - , InfixR (binary "++") ] - -- 4 - , [ InfixL (binary "=") - , InfixL (binary "<=") - , InfixL (binary "<" ) - , InfixL (binary ">=") - , InfixL (binary ">" ) ] - -- 3 - , [ InfixR (binary "&&") ] - -- 2 - , [ InfixR (binary "||") ] - ] + unary :: String -> Parser (EgisonExpr -> EgisonExpr) + unary sym = UnaryOpExpr <$> operator sym + binary :: String -> Parser (EgisonExpr -> EgisonExpr -> EgisonExpr) + binary sym = do + -- TODO: Is this indentation guard necessary? + op <- try (L.indentGuard sc GT pos >> binOpLiteral sym <* notFollowedBy (symbol ")")) + return $ BinaryOpExpr op + + binOpToOperator :: EgisonBinOp -> Operator Parser EgisonExpr + binOpToOperator op = case assoc op of + LeftAssoc -> InfixL (binary (repr op)) + RightAssoc -> InfixR (binary (repr op)) + NonAssoc -> InfixN (binary (repr op)) + + ifExpr :: Parser EgisonExpr -ifExpr = keywordIf >> IfExpr <$> expr <* keywordThen <*> expr <* keywordElse <*> expr +ifExpr = reserved "if" >> IfExpr <$> expr <* reserved "then" <*> expr <* reserved "else" <*> expr patternMatchExpr :: Parser EgisonExpr -patternMatchExpr = makeMatchExpr keywordMatch (MatchExpr BFSMode) - <|> makeMatchExpr keywordMatchDFS (MatchExpr DFSMode) - <|> makeMatchExpr keywordMatchAll (MatchAllExpr BFSMode) - <|> makeMatchExpr keywordMatchAllDFS (MatchAllExpr DFSMode) +patternMatchExpr = makeMatchExpr (reserved "match") (MatchExpr BFSMode) + <|> makeMatchExpr (reserved "matchDFS") (MatchExpr DFSMode) + <|> makeMatchExpr (reserved "matchAll") (MatchAllExpr BFSMode) + <|> makeMatchExpr (reserved "matchAllDFS") (MatchAllExpr DFSMode) "pattern match expression" where makeMatchExpr keyword ctor = ctor <$> (keyword >> expr) - <*> (keywordAs >> expr) - <*> (keywordWith >> matchClauses1) + <*> (reserved "as" >> expr) + <*> (reserved "with" >> matchClauses1) -- Parse more than 1 match clauses. matchClauses1 :: Parser [MatchClause] @@ -263,15 +269,15 @@ lambdaExpr :: Parser EgisonExpr lambdaExpr = symbol "\\" >> ( - makeMatchLambdaExpr keywordMatch MatchLambdaExpr - <|> makeMatchLambdaExpr keywordMatchAll MatchAllLambdaExpr + makeMatchLambdaExpr (reserved "match") MatchLambdaExpr + <|> makeMatchLambdaExpr (reserved "matchAll") MatchAllLambdaExpr <|> try (LambdaExpr <$> some arg <*> (symbol "->" >> expr)) <|> PatternFunctionExpr <$> some lowerId <*> (symbol "=>" >> pattern)) "lambda or pattern function expression" where makeMatchLambdaExpr keyword ctor = do - matcher <- keyword >> keywordAs >> expr - clauses <- keywordWith >> matchClauses1 + matcher <- keyword >> reserved "as" >> expr + clauses <- reserved "with" >> matchClauses1 return $ ctor matcher clauses arg :: Parser Arg @@ -282,10 +288,13 @@ letExpr :: Parser EgisonExpr letExpr = do - pos <- keywordLet >> L.indentLevel - binds <- some (L.indentGuard sc EQ pos *> binding) - body <- keywordIn >> expr + pos <- reserved "let" >> L.indentLevel + binds <- oneLiner <|> some (L.indentGuard sc EQ pos *> binding) + body <- reserved "in" >> expr return $ LetRecExpr binds body + where + oneLiner :: Parser [BindingExpr] + oneLiner = braces $ sepBy binding (symbol ";") binding :: Parser BindingExpr binding = do @@ -299,24 +308,29 @@ _ -> (vars, LambdaExpr args body) withSymbolsExpr :: Parser EgisonExpr -withSymbolsExpr = WithSymbolsExpr <$> (keywordWithSymbols >> brackets (sepBy lowerId comma)) <*> expr +withSymbolsExpr = WithSymbolsExpr <$> (reserved "withSymbols" >> brackets (sepBy lowerId comma)) <*> expr doExpr :: Parser EgisonExpr doExpr = do - pos <- keywordDo >> L.indentLevel - stmts <- some $ L.indentGuard sc EQ pos >> statement - ret <- option (makeApply' "return" []) $ L.indentGuard sc EQ pos >> expr - return $ DoExpr stmts ret + pos <- reserved "do" >> L.indentLevel + stmts <- oneLiner <|> some (L.indentGuard sc EQ pos >> statement) + return $ case last stmts of + ([], retExpr@(ApplyExpr (VarExpr (Var ["return"] _)) _)) -> + DoExpr (init stmts) retExpr + _ -> DoExpr stmts (makeApply' "return" []) where statement :: Parser BindingExpr - statement = (keywordLet >> binding) <|> ([],) <$> expr + statement = (reserved "let" >> binding) <|> ([],) <$> expr + oneLiner :: Parser [BindingExpr] + oneLiner = braces $ sepBy statement (symbol ";") + ioExpr :: Parser EgisonExpr -ioExpr = IoExpr <$> (keywordIo >> expr) +ioExpr = IoExpr <$> (reserved "io" >> expr) matcherExpr :: Parser EgisonExpr matcherExpr = do - keywordMatcher + reserved "matcher" pos <- L.indentLevel -- In matcher expression, the first '|' (bar) is indispensable info <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef) @@ -325,7 +339,7 @@ patternDef :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) patternDef = do pp <- ppPattern - returnMatcher <- keywordAs >> expr <* keywordWith + returnMatcher <- reserved "as" >> expr <* reserved "with" pos <- L.indentLevel datapat <- some (L.indentGuard sc EQ pos >> symbol "|" >> dataCases) return (pp, returnMatcher, datapat) @@ -335,7 +349,7 @@ algebraicDataMatcherExpr :: Parser EgisonExpr algebraicDataMatcherExpr = do - keywordAlgebraicDataMatcher + reserved "algebraicDataMatcher" pos <- L.indentLevel defs <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef) return $ AlgebraicDataMatcherExpr defs @@ -348,24 +362,24 @@ return (patternCtor, args) memoizedLambdaExpr :: Parser EgisonExpr -memoizedLambdaExpr = MemoizedLambdaExpr <$> (keywordMemoizedLambda >> many lowerId) <*> (symbol "->" >> expr) +memoizedLambdaExpr = MemoizedLambdaExpr <$> (reserved "memoizedLambda" >> many lowerId) <*> (symbol "->" >> expr) procedureExpr :: Parser EgisonExpr -procedureExpr = ProcedureExpr <$> (keywordProcedure >> many lowerId) <*> (symbol "->" >> expr) +procedureExpr = ProcedureExpr <$> (reserved "procedure" >> many lowerId) <*> (symbol "->" >> expr) macroExpr :: Parser EgisonExpr -macroExpr = MacroExpr <$> (keywordMacro >> many lowerId) <*> (symbol "->" >> expr) +macroExpr = MacroExpr <$> (reserved "macro" >> many lowerId) <*> (symbol "->" >> expr) generateTensorExpr :: Parser EgisonExpr -generateTensorExpr = GenerateTensorExpr <$> (keywordGenerateTensor >> atomExpr) <*> atomExpr +generateTensorExpr = GenerateTensorExpr <$> (reserved "generateTensor" >> atomExpr) <*> atomExpr tensorExpr :: Parser EgisonExpr -tensorExpr = TensorExpr <$> (keywordTensor >> atomExpr) <*> atomExpr +tensorExpr = TensorExpr <$> (reserved "tensor" >> atomExpr) <*> atomExpr <*> option (CollectionExpr []) atomExpr <*> option (CollectionExpr []) atomExpr functionExpr :: Parser EgisonExpr -functionExpr = FunctionExpr <$> (keywordFunction >> parens (sepBy expr comma)) +functionExpr = FunctionExpr <$> (reserved "function" >> parens (sepBy expr comma)) collectionExpr :: Parser EgisonExpr collectionExpr = symbol "[" >> (try betweenOrFromExpr <|> elementsExpr) @@ -465,7 +479,7 @@ atomExpr' :: Parser EgisonExpr atomExpr' = constantExpr <|> VarExpr <$> varLiteral - <|> (\x -> InductiveDataExpr x []) <$> upperId + <|> inductiveDataOrModuleExpr <|> vectorExpr -- must come before collectionExpr <|> arrayExpr -- must come before tupleOrParenExpr <|> collectionExpr @@ -475,13 +489,20 @@ <|> QuoteSymbolExpr <$> (char '`' >> atomExpr') "atomic expression" +inductiveDataOrModuleExpr :: Parser EgisonExpr +inductiveDataOrModuleExpr = do + (ident, rest) <- upperOrModuleId + return $ case rest of + [] -> InductiveDataExpr ident [] + _ -> VarExpr (Var (ident : rest) []) + constantExpr :: Parser EgisonExpr constantExpr = numericExpr <|> BoolExpr <$> boolLiteral <|> CharExpr <$> try charLiteral -- try for quoteExpr <|> StringExpr . pack <$> stringLiteral - <|> SomethingExpr <$ keywordSomething - <|> UndefinedExpr <$ keywordUndefined + <|> SomethingExpr <$ reserved "something" + <|> UndefinedExpr <$ reserved "undefined" numericExpr :: Parser EgisonExpr numericExpr = FloatExpr <$> try positiveFloatLiteral @@ -499,14 +520,14 @@ letPattern :: Parser EgisonPattern letPattern = do - pos <- keywordLet >> L.indentLevel + pos <- reserved "let" >> L.indentLevel binds <- some (L.indentGuard sc EQ pos *> binding) - body <- keywordIn >> pattern + body <- reserved "in" >> pattern return $ LetPat binds body loopPattern :: Parser EgisonPattern loopPattern = - LoopPat <$> (keywordLoop >> patVarLiteral) <*> loopRange + LoopPat <$> (reserved "loop" >> patVarLiteral) <*> loopRange <*> atomPattern <*> atomPattern where loopRange :: Parser LoopRange @@ -550,6 +571,7 @@ case (func, args) of (_, []) -> return func (InductivePat x [], _) -> return $ InductivePat x args + _ -> error (show (func, args)) atomPattern :: Parser EgisonPattern atomPattern = do @@ -705,50 +727,22 @@ then fail $ "keyword " ++ show x ++ " cannot be an identifier" else return x -keywordLoadFile = reserved "loadFile" -keywordLoad = reserved "load" -keywordIf = reserved "if" -keywordThen = reserved "then" -keywordElse = reserved "else" -keywordSeq = reserved "seq" -keywordApply = reserved "apply" -keywordCApply = reserved "capply" -keywordMemoizedLambda = reserved "memoizedLambda" -keywordCambda = reserved "cambda" -keywordProcedure = reserved "procedure" -keywordMacro = reserved "macro" -keywordLet = reserved "let" -keywordIn = reserved "in" -keywordWithSymbols = reserved "withSymbols" -keywordLoop = reserved "loop" -keywordMatch = reserved "match" -keywordMatchDFS = reserved "matchDFS" -keywordMatchAll = reserved "matchAll" -keywordMatchAllDFS = reserved "matchAllDFS" -keywordAs = reserved "as" -keywordWith = reserved "with" -keywordMatcher = reserved "matcher" -keywordDo = reserved "do" -keywordIo = reserved "io" -keywordSomething = reserved "something" -keywordUndefined = reserved "undefined" -keywordAlgebraicDataMatcher = reserved "algebraicDataMatcher" -keywordGenerateTensor = reserved "generateTensor" -keywordTensor = reserved "tensor" -keywordTensorContract = reserved "contract" -keywordSubrefs = reserved "subrefs" -keywordSubrefsNew = reserved "subrefs!" -keywordSuprefs = reserved "suprefs" -keywordSuprefsNew = reserved "suprefs!" -keywordUserrefs = reserved "userRefs" -keywordUserrefsNew = reserved "userRefs!" -keywordFunction = reserved "function" +-- Parses both InductiveDataExpr and Var with module +-- ex. "Greater" -> ("Greater", []) +-- "S.intercalate" -> ("S", ["intercalate"]) +upperOrModuleId :: Parser (String, [String]) +upperOrModuleId = do + ident <- (:) <$> upperChar <*> many alphaNumChar + follows <- many (char '.' >> some alphaNumChar) <* sc + return (ident, follows) +upperReservedWords :: [String] upperReservedWords = [ "True" , "False" ] +lowerReservedWords :: [String] lowerReservedWords = [ "loadFile" , "load" @@ -764,10 +758,9 @@ , "macro" , "let" , "in" + , "where" , "withSymbols" , "loop" - , "from" - , "to" , "of" , "match" , "matchDFS" diff --git a/hs-src/Language/Egison/Pretty.hs b/hs-src/Language/Egison/Pretty.hs --- a/hs-src/Language/Egison/Pretty.hs +++ b/hs-src/Language/Egison/Pretty.hs @@ -33,7 +33,7 @@ instance Pretty EgisonTopExpr where pretty (Define x (LambdaExpr args body)) = - pretty x <+> hsep (map pretty args) <+> pretty ":=" <> nest 2 (softline <> pretty body) + pretty x <+> hsep (map pretty args) <+> pretty ":=" <> nest 2 (hardline <> pretty body) pretty (Define x expr) = pretty x <+> pretty ":=" <> nest 2 (softline <> pretty expr) pretty (Test expr) = pretty expr pretty (LoadFile file) = pretty "loadFile" <+> pretty (show file) @@ -93,8 +93,12 @@ else pretty x <+> pretty (repr op) <+> pretty' y pretty (BinaryOpExpr op x y) = pretty x <+> pretty (repr op) <+> pretty' y - pretty (ApplyExpr x (TupleExpr ys)) = nest 2 (pretty x <+> fillSep (map pretty ys)) + -- TODO: Fix display of binding expr for do + pretty (DoExpr xs y) = pretty "do" <+> pretty xs <> hardline <> pretty y + pretty (IoExpr x) = pretty "io" <+> pretty x + pretty (ApplyExpr x (TupleExpr ys)) = nest 2 (pretty x <+> fillSep (map pretty' ys)) + pretty SomethingExpr = pretty "something" pretty UndefinedExpr = pretty "undefined" @@ -119,23 +123,43 @@ pretty (pat, expr) = pipe <+> pretty pat <+> pretty "->" <> softline <> pretty expr instance Pretty EgisonPattern where + -- TODO: Add parenthesis according to priority pretty WildCard = pretty "_" pretty (PatVar x) = pretty "$" <> pretty x - pretty (ValuePat v) = pretty "#" <> parens (pretty v) -- TODO: remove parens - pretty (PredPat v) = pretty "?" <> parens (pretty v) + pretty (ValuePat v) = pretty "#" <> pretty v + pretty (PredPat v) = pretty "?" <> pretty v + pretty (InductivePat "nil" []) = pretty "[]" + pretty (InductivePat "cons" [x, y]) = pretty x <+> pretty "::" <+> pretty y + pretty (InductivePat "join" [x, y]) = pretty x <+> pretty "++" <+> pretty y + pretty (InductivePat ctor xs) = pretty ctor <+> hsep (map pretty xs) + pretty (AndPat xs) = pintercalate (pretty "&") (map pretty xs) + pretty (OrPat xs) = pintercalate (pretty "|") (map pretty xs) + pretty (TuplePat xs) = tupled $ map pretty xs pretty _ = pretty "hoge" pretty' :: EgisonExpr -> Doc ann -pretty' x@(UnaryOpExpr _ _) = parens $ pretty x -pretty' x = pretty x +pretty' x = + case x of + UnaryOpExpr _ _ -> parens $ pretty x + ApplyExpr _ _ -> parens $ pretty x + LambdaExpr _ _ -> parens $ pretty x + IfExpr _ _ _ -> parens $ pretty x + LetRecExpr _ _ -> parens $ pretty x + MatchExpr _ _ _ _ -> parens $ pretty x + MatchLambdaExpr _ _ -> parens $ pretty x + MatchAllLambdaExpr _ _ -> parens $ pretty x + _ -> pretty x prettyMatch :: EgisonExpr -> [MatchClause] -> Doc ann prettyMatch matcher clauses = - pretty "as" <+> pretty matcher <+> pretty "with" <> hardline <> - align (vsep (map pretty clauses)) + pretty "as" <+> group (pretty matcher) <+> pretty "with" <> + (nest 2 (hardline <> align (vsep (map pretty clauses)))) listoid :: String -> String -> [Doc ann] -> Doc ann listoid lp rp elems = encloseSep (pretty lp) (pretty rp) (comma <> space) elems + +pintercalate :: Doc ann -> [Doc ann] -> Doc ann +pintercalate sep elems = encloseSep emptyDoc emptyDoc (space <> sep <> space) elems -- -- Pretty printer for S-expression diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -17,8 +17,8 @@ ( -- * Egison values EgisonValue (..) - , Matcher (..) - , PrimitiveFunc (..) + , Matcher + , PrimitiveFunc , ScalarData (..) , PolyExpr (..) , TermExpr (..) @@ -69,7 +69,7 @@ , extractScalar' -- * Internal data , Object (..) - , ObjectRef (..) + , ObjectRef , WHNFData (..) , Intermediate (..) , Inner (..) @@ -77,7 +77,7 @@ -- * Environment , Env (..) , VarWithIndices (..) - , Binding (..) + , Binding , nullEnv , extendEnv , refVar @@ -86,7 +86,7 @@ , Match , MatchingTree (..) , MatchingState (..) - , PatternBinding (..) + , PatternBinding , LoopPatContext (..) , SeqPatContext (..) -- * Errors @@ -98,10 +98,10 @@ , liftEgisonM , fromEgisonM , FreshT (..) - , Fresh (..) + , Fresh , MonadFresh (..) , runFreshT - , MatchM (..) + , MatchM , matchFail , MList (..) , fromList diff --git a/hs-src/Tool/translator.hs b/hs-src/Tool/translator.hs --- a/hs-src/Tool/translator.hs +++ b/hs-src/Tool/translator.hs @@ -19,7 +19,7 @@ instance SyntaxElement EgisonTopExpr where toNonS (Define x y) = Define (toNonS x) (toNonS y) - toNonS (Redefine x y) = error "Not supported" + toNonS (Redefine _ _) = error "Not supported" toNonS (Test x) = Test (toNonS x) toNonS (Execute x) = Execute (toNonS x) toNonS x = x @@ -70,11 +70,11 @@ toNonS (DoExpr xs y) = DoExpr (map toNonS xs) (toNonS y) toNonS (IoExpr x) = IoExpr (toNonS x) - toNonS (ApplyExpr x@(VarExpr (Var [f] [])) (TupleExpr (y:ys))) - | any (\op -> repr op == f) reservedBinops = + toNonS (ApplyExpr (VarExpr (Var [f] [])) (TupleExpr (y:ys))) + | any (\op -> func op == f) reservedBinops = foldl (\acc x -> BinaryOpExpr op acc (toNonS x)) (toNonS y) ys where - op = fromJust $ find (\op -> repr op == f) reservedBinops + op = fromJust $ find (\op -> func op == f) reservedBinops toNonS (ApplyExpr x y) = ApplyExpr (toNonS x) (toNonS y) toNonS x = x diff --git a/nons-test/test/dp.egi b/nons-test/test/dp.egi --- a/nons-test/test/dp.egi +++ b/nons-test/test/dp.egi @@ -38,10 +38,10 @@ -> dp vs (resolveOn v cnf ++ deleteClausesWith v (deleteClausesWith (neg v) cnf)) -dp [1] [[1]] -- True -dp [1] [[1],[-1]] -- False -dp [1,2,3] [[1,2],[-1,3],[1,-3]] -- True -dp [1,2] [[1,2],[-1,-2],[1,-2]] -- True -dp [1,2] [[1,2],[-1,-2],[1,-2],[-1,2]] -- False -dp [1,2,3,4,5] [[-1,-2,3],[-1,-2,-3],[1,2,3,4],[-4,-2,3],[5,1,2,-3],[-3,1,-5],[1,-2,3,4],[1,-2,-3,5]] -- True -dp [1,2] [[-1,-2],[1]] -- True +assertEqual "dp" (dp [1] [[1]]) True +assertEqual "dp" (dp [1] [[1],[-1]]) False +assertEqual "dp" (dp [1,2,3] [[1,2],[-1,3],[1,-3]]) True +assertEqual "dp" (dp [1,2] [[1,2],[-1,-2],[1,-2]]) True +assertEqual "dp" (dp [1,2] [[1,2],[-1,-2],[1,-2],[-1,2]]) False +assertEqual "dp" (dp [1,2,3,4,5] [[-1,-2,3],[-1,-2,-3],[1,2,3,4],[-4,-2,3],[5,1,2,-3],[-3,1,-5],[1,-2,3,4],[1,-2,-3,5]]) True +assertEqual "dp" (dp [1,2] [[-1,-2],[1]]) True diff --git a/nons-test/test/poker-joker.egi b/nons-test/test/poker-joker.egi new file mode 100644 --- /dev/null +++ b/nons-test/test/poker-joker.egi @@ -0,0 +1,37 @@ +suit := algebraicDataMatcher + | spade + | heart + | club + | diamond + +card := matcher + | card $ $ as (suit, mod 13) with + | Card $s $n -> [(s, n)] + | Joker -> matchAll ([Spade, Heart, Club, Diamond], [1..13]) + as (set suit, set integer) with + | ($s :: _, $n :: _) -> (s, n) + | $ as something with + | $tgt -> [tgt] + +poker cs := + match cs as multiset card with + | card $s $n :: card #s #(n-1) :: card #s #(n-2) :: card #s #(n-3) :: card #s #(n-4) :: _ + -> "Straight flush" + | card _ $n :: card _ #n :: card _ #n :: card _ #n :: _ :: [] + -> "Four of a kind" + | card _ $m :: card _ #m :: card _ #m :: card _ $n :: card _ #n :: [] + -> "Full house" + | card $s _ :: card #s _ :: card #s _ :: card #s _ :: card #s _ :: [] + -> "Flush" + | card _ $n :: card _ #(n-1) :: card _ #(n-2) :: card _ #(n-3) :: card _ #(n-4) :: [] + -> "Straight" + | card _ $n :: card _ #n :: card _ #n :: _ :: _ :: [] + -> "Three of a kind" + | card _ $m :: card _ #m :: card _ $n :: card _ #n :: _ :: [] + -> "Two pair" + | card _ $n :: card _ #n :: _ :: _ :: _ :: [] + -> "One pair" + | _ :: _ :: _ :: _ :: _ :: [] -> "Nothing" + +assertEqual "poker-joker" (poker [Card Spade 5, Card Spade 6, Joker, Card Spade 8, Card Spade 9]) "Straight flush" +assertEqual "poker-joker" (poker [Card Spade 5, Card Diamond 5, Joker, Card Club 5, Card Heart 7]) "Four of a kind" diff --git a/nons-test/test/poker.egi b/nons-test/test/poker.egi --- a/nons-test/test/poker.egi +++ b/nons-test/test/poker.egi @@ -28,12 +28,12 @@ | _ :: _ :: _ :: _ :: _ :: [] -> "Nothing" -poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Spade 9] -- "Straight flush" -poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 5] -- "Four of a kind" -poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 7] -- "Full house" -poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 13, Card Spade 9] -- "Flush" -poker [Card Spade 5, Card Club 6, Card Spade 7, Card Spade 8, Card Spade 9] -- "Straight" -poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 8] -- "Three of a kind" -poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 10] -- "Two pair" -poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 8] -- "One pair" -poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Diamond 11] -- "Nothing" +assertEqual "poker" (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Spade 9]) "Straight flush" +assertEqual "poker" (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 5]) "Four of a kind" +assertEqual "poker" (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 7]) "Full house" +assertEqual "poker" (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 13, Card Spade 9]) "Flush" +assertEqual "poker" (poker [Card Spade 5, Card Club 6, Card Spade 7, Card Spade 8, Card Spade 9]) "Straight" +assertEqual "poker" (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 8]) "Three of a kind" +assertEqual "poker" (poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 10]) "Two pair" +assertEqual "poker" (poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 8]) "One pair" +assertEqual "poker" (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Diamond 11]) "Nothing" diff --git a/nons-test/test/syntax.egi b/nons-test/test/syntax.egi --- a/nons-test/test/syntax.egi +++ b/nons-test/test/syntax.egi @@ -62,6 +62,29 @@ in y) 2 +assertEqual "let binding without indent" + (let { x := 1; y := x + 1 } in y) + 2 + +io do print "io and do expression" + return 0 + +io do { print "io and do expression without indent"; return 0 } + +assertEqual "where" + (f 0 + y + 1 + where f x := 2 + x + y := 3) + 6 + +assertEqual "nested where" + (f 0 + 1 + where + f x := 2 + y + z + where y := 3 + z := 4) + 10 + assertEqual "mutual recursion" (let even? n := if n = 0 then True else odd? (n - 1) odd? n := if n = 0 then False else even? (n - 1) @@ -104,7 +127,8 @@ primeTriplets := matchAll primes as list integer with - | _ ++ $p :: ((#(p + 2) | #(p + 4)) & $m) :: #(p + 6) :: _ -> (p, m, p + 6) + | _ ++ $p :: ((#(p + 2) | #(p + 4)) & $m) :: #(p + 6) :: _ + -> (p, m, p + 6) assertEqual "prime triplets" (take 10 primeTriplets) @@ -118,10 +142,10 @@ 7 gcd m n := - if (m >= n) then - if (n = 0) then m - else gcd n (m % n) - else gcd n m + if m >= n then + if n = 0 then m + else gcd n (m % n) + else gcd n m assertEqual "recursive function definition" (gcd 143 22) @@ -313,6 +337,16 @@ | _ ++ $m :: _ ++ $n :: _ -> [m, n])) [[1, 2], [1, 3], [2, 3], [1, 4], [2, 4], [3, 4], [1, 5], [2, 5], [3, 5], [4, 5]] +assertEqual "combinations" + (matchAll [1,2,3] as list something with + | _ ++ $x :: _ ++ $y :: _ -> (x, y)) + [(1, 2), (1, 3), (2, 3)] + +assertEqual "permutations" + (matchAll [1,2,3] as multiset something with + | $x :: $y :: _ -> (x, y)) + [(1, 2), (1, 3), (2, 1), (2, 3), (3, 1), (3, 2)] + tree a := algebraicDataMatcher | leaf | node (tree a) a (tree a) @@ -340,9 +374,17 @@ assert "sequential pattern" (match [2,3,1,4,5] as list integer with - { @ :: @ :: $x :: _, - (#(x + 1), @), - #(x + 2)} -> True) + | { @ :: @ :: $x :: _, + (#(x + 1), @), + #(x + 2)} + -> True) + +assertEqual "sequential not pattern" + (matchAll ([1,2,3], [4,3,5]) as (multiset eq, multiset eq) with + | { ($x :: @, #x :: @), + !($y :: _, #y :: _) } + -> x) + [3] -- -- Tensor