diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.7.13 +Version: 3.7.14 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/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -74,11 +74,6 @@ "\\" "\\" "\\" - "\\" - "\\" - "\\" - "\\" - "\\" "\\" "\\" "\\" @@ -90,7 +85,7 @@ "\\" "\\" - + "\\\.\\\.\\\." "\\\," ; "'" @@ -202,10 +197,6 @@ ((equal "match-lambda" name) 2) ((equal "match-all" name) 2) ((equal "match-all-lambda" name) 2) - ((equal "next-match" name) 2) - ((equal "next-match-lambda" name) 2) - ((equal "next-match-all" name) 2) - ((equal "next-match-all-lambda" name) 2) ((equal "matcher" name) 2) ((equal "algebraic-data-matcher" name) 2) ((equal "pattern-function" name) 2) diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -232,10 +232,7 @@ f (x, _) = x g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)), ms) = let Env _ maybe_vwi = env in - let fn' = case maybe_vwi of - Nothing -> fn - Just (VarWithIndices nameString indexList) -> - Just $ symbolScalarData "" $ show $ VarWithIndices nameString $ changeIndexList indexList ms in + let fn' = maybe fn (\(VarWithIndices nameString indexList) -> Just $ symbolScalarData "" $ show $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi in Value $ ScalarData $ Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p g (x, _) = x @@ -694,12 +691,10 @@ ns <- (mapM fromEgison size'') :: EgisonM [Integer] let Env frame maybe_vwi = env xs <- mapM (\ms -> do - let env' = case maybe_vwi of - Nothing -> env - Just (VarWithIndices nameString indexList) -> Env frame (Just $ VarWithIndices nameString $ changeIndexList indexList ms) + let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi fn <- evalExpr env' fnExpr - applyFunc env fn (Value (makeTuple ms))) - (map (\ms -> map toEgison ms) (enumTensorIndices ns)) + applyFunc env fn $ Value $ makeTuple ms) + (map (\ms -> map toEgison ms) $ enumTensorIndices ns) fromTensor (Tensor ns (V.fromList xs) []) evalExpr env (TensorContractExpr fnExpr tExpr) = do @@ -1027,8 +1022,7 @@ whnf <- evalExpr env' expr case whnf of (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ (Value (CFunc (Just name) env arg body)) - FunctionExpr args -> do - liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ FunctionExpr args + FunctionExpr args -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ FunctionExpr args _ | isVarWithIndices name -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) expr | otherwise -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr) refs bindings @@ -1068,9 +1062,15 @@ processMStatesAll depth streams = do (matches, streams') <- (\(a, b) -> (fromList a, b)) <$> (processMStatesLine depth streams >>= extractMatches) if null (streams' ^. normalTree) - then do matches' <- mapM (\id -> processMStatesAll 0 $ MatchingStates { _normalTree = map snd (toAscList $ (streams' ^. orderedOrTrees) M.! id), _orderedOrTrees = M.empty, _ids = [], _bool = streams' ^. bool }) $ streams' ^. ids + then do matches' <- mapM (\id -> processMStatesAll 0 $ MatchingStates { _normalTree = convert ((streams' ^. orderedOrTrees) M.! id), _orderedOrTrees = M.empty, _ids = [], _bool = streams' ^. bool }) $ streams' ^. ids mappend matches $ mconcat $ fromList matches' else mappend matches $ processMStatesAll (depth + 1) streams' + where + convert :: Map Int [a] -> [[a]] + convert ms = let ((start, root), ms') = M.deleteFindMin ms in + M.foldlWithKey (\l k x -> let k' = k - start in + if length l <= k' then l ++ (replicate (k' - length l) []) ++ [x] + else let (xs, y:ys) = splitAt k' l in xs ++ (x:ys)) [root] ms' processMStatesLine :: Int -> MatchingStates -> EgisonM MatchingStates processMStatesLine depth streams = do @@ -1169,6 +1169,9 @@ case result of MNil -> return $ msingleton state2 _ -> return MNil + MAtom (LaterPat _) _ _ -> do + let state' = swapMState state + processMState' state' _ -> processMState' state where splitMState :: MatchingState -> (MatchingState, MatchingState) @@ -1177,6 +1180,12 @@ splitMState (MState mode env loops bindings ((MNode penv state') : trees)) = let (state1, state2) = splitMState state' in (MState mode env loops bindings [MNode penv state1], MState mode env loops bindings (MNode penv state2 : trees)) + swapMState :: MatchingState -> MatchingState + swapMState (MState mode env loops bindings ((MAtom (LaterPat pattern) target matcher) : trees)) = + MState mode env loops bindings (trees ++ [MAtom pattern target matcher]) + swapMState (MState mode env loops bindings ((MNode penv state') : trees)) = + let state'' = swapMState state' + in MState mode env loops bindings ((MNode penv state''):trees) processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState) processMState' (MState _ _ _ _ []) = throwError $ EgisonBug "should not reach here (empty matching-state)" @@ -1284,11 +1293,20 @@ _ -> case matcher of UserMatcher _ _ _ -> do - (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher - mfor targetss $ \ref -> do - targets <- evalRef ref >>= fromTupleWHNF - let trees' = zipWith3 MAtom patterns targets matchers ++ trees - return $ MState mode env loops bindings trees' + case pattern of + _ -> do + (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher + case (length patterns, length matchers) of + (1,1) -> do + mfor targetss $ \ref -> do + targets <- evalRef ref >>= (\x -> return [x]) + let trees' = zipWith3 MAtom patterns targets matchers ++ trees + return $ MState mode env loops bindings trees' + _ -> do + mfor targetss $ \ref -> do + targets <- evalRef ref >>= fromTupleWHNF + let trees' = zipWith3 MAtom patterns targets matchers ++ trees + return $ MState mode env loops bindings trees' Tuple matchers -> case pattern of diff --git a/hs-src/Language/Egison/Desugar.hs b/hs-src/Language/Egison/Desugar.hs --- a/hs-src/Language/Egison/Desugar.hs +++ b/hs-src/Language/Egison/Desugar.hs @@ -435,6 +435,7 @@ collectName :: EgisonPattern -> Set String collectName (NotPat pattern) = collectName pattern + collectName (LaterPat pattern) = collectName pattern collectName (AndPat patterns) = collectNames patterns collectName (TuplePat patterns) = collectNames patterns collectName (InductivePat _ patterns) = collectNames patterns @@ -459,6 +460,7 @@ desugarPattern' (ValuePat expr) = ValuePat <$> desugar expr desugarPattern' (PredPat expr) = PredPat <$> desugar expr desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern +desugarPattern' (LaterPat pattern) = LaterPat <$> desugarPattern' pattern desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns desugarPattern' (OrPat patterns) = OrPat <$> mapM desugarPattern' patterns desugarPattern' (OrderedOrPat' [pat1, pat2]) = OrderedOrPat <$> fresh <*> desugarPattern' pat1 <*> desugarPattern' pat2 diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -122,6 +122,10 @@ fromParsecError :: ParseError -> EgisonError fromParsecError = Parser . show +doParse' :: Parser a -> String -> a +doParse' p input = case doParse p input of + Right x -> x + -- -- Expressions -- @@ -140,7 +144,7 @@ <|> try (parens (do keywordDefine (VarWithIndices name is) <- (char '$' >> identVarWithIndices) body <- expr - return $ Define (Var name (map f is)) (WithSymbolsExpr (map g is) (TransposeExpr (CollectionExpr (map (ElementExpr . h) is)) body)))) + return $ Define (Var name (map f is)) (WithSymbolsExpr (map g is) (TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) body)))) where f (Superscript _) = Superscript () f (Subscript _) = Subscript () @@ -148,9 +152,6 @@ g (Superscript i) = i g (Subscript i) = i g (SupSubscript i) = i - h (Superscript i) = (VarExpr $ stringToVar i) - h (Subscript i) = (VarExpr $ stringToVar i) - h (SupSubscript i) = (VarExpr $ stringToVar i) redefineExpr :: Parser EgisonTopExpr redefineExpr = (keywordRedefine <|> keywordSet) >> Redefine <$> (char '$' >> identVar) <*> expr @@ -230,10 +231,6 @@ <|> matchExpr <|> matchAllLambdaExpr <|> matchLambdaExpr - <|> nextMatchAllExpr - <|> nextMatchExpr - <|> nextMatchAllLambdaExpr - <|> nextMatchLambdaExpr <|> matcherExpr <|> matcherDFSExpr <|> seqExpr @@ -329,18 +326,6 @@ matchLambdaExpr :: Parser EgisonExpr matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses -nextMatchAllExpr :: Parser EgisonExpr -nextMatchAllExpr = keywordNextMatchAll >> NextMatchAllExpr <$> expr <*> expr <*> matchClause - -nextMatchExpr :: Parser EgisonExpr -nextMatchExpr = keywordNextMatch >> NextMatchExpr <$> expr <*> expr <*> matchClauses - -nextMatchAllLambdaExpr :: Parser EgisonExpr -nextMatchAllLambdaExpr = keywordNextMatchAllLambda >> NextMatchAllLambdaExpr <$> expr <*> matchClause - -nextMatchLambdaExpr :: Parser EgisonExpr -nextMatchLambdaExpr = keywordNextMatchLambda >> NextMatchLambdaExpr <$> expr <*> matchClauses - matchClauses :: Parser [MatchClause] matchClauses = braces $ sepEndBy matchClause whiteSpace @@ -540,9 +525,7 @@ generateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> expr <*> arrayRange arrayRange :: Parser (EgisonExpr, EgisonExpr) -arrayRange = brackets (do s <- expr - e <- expr - return (s, e)) +arrayRange = brackets $ (,) <$> expr <*> expr arrayBoundsExpr :: Parser EgisonExpr arrayBoundsExpr = keywordArrayBounds >> ArrayBoundsExpr <$> expr @@ -611,6 +594,7 @@ <|> orPat <|> loopPat <|> letPat + <|> laterPat <|> bfsPat <|> dfsPat <|> try divPat @@ -618,7 +602,6 @@ <|> try multPat <|> try dApplyPat <|> try pApplyPat --- <|> powerPat ) pattern'' :: Parser EgisonPattern @@ -644,6 +627,9 @@ letPat :: Parser EgisonPattern letPat = keywordLet >> LetPat <$> bindings <*> pattern +laterPat :: Parser EgisonPattern +laterPat = keywordLater >> LaterPat <$> pattern + notPat :: Parser EgisonPattern notPat = char '!' >> NotPat <$> pattern @@ -678,13 +664,10 @@ loopPat = keywordLoop >> char '$' >> LoopPat <$> identVarWithoutIndex <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern loopRange :: Parser LoopRange -loopRange = brackets (try (do s <- expr - e <- expr +loopRange = brackets (try (LoopRange <$> expr <*> expr <*> option WildCard pattern) + <|> (do s <- expr ep <- option WildCard pattern - return (LoopRange s e ep)) - <|> (do s <- expr - ep <- option WildCard pattern - return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, (IntegerExpr 1)]))) ep))) + return (LoopRange s (ApplyExpr (VarExpr $ stringToVar "from") (ApplyExpr (VarExpr $ stringToVar "-'") (TupleExpr [s, (IntegerExpr 1)]))) ep))) divPat :: Parser EgisonPattern divPat = reservedOp "/" >> DivPat <$> pattern <*> pattern @@ -696,11 +679,8 @@ multPat = reservedOp "*" >> MultPat <$> sepEndBy powerPat whiteSpace powerPat :: Parser EgisonPattern -powerPat = try (do pat1 <- pattern - char '^' - pat2 <- pattern - return $ PowerPat pat1 pat2) - <|> pattern +powerPat = try (PowerPat <$> pattern <* char '^' <*> pattern) + <|> pattern dfsPat :: Parser EgisonPattern dfsPat = keywordDFS >> DFSPat' <$> pattern @@ -721,7 +701,7 @@ "constant" charExpr :: Parser EgisonExpr -charExpr = CharExpr <$> charLiteral +charExpr = CharExpr <$> oneChar stringExpr :: Parser EgisonExpr stringExpr = StringExpr . T.pack <$> stringLiteral @@ -731,15 +711,9 @@ floatExpr :: Parser EgisonExpr floatExpr = do - (x,y) <- try (do x <- floatLiteral' - y <- sign' <*> positiveFloatLiteral - char 'i' - return (x,y)) - <|> try (do y <- floatLiteral' - char 'i' - return (0,y)) - <|> try (do x <- floatLiteral' - return (x,0)) + (x,y) <- try ((,) <$> floatLiteral' <*> (sign' <*> positiveFloatLiteral) <* char 'i') + <|> try ((,) 0 <$> floatLiteral' <* char 'i') + <|> try (flip (,) 0 <$> floatLiteral') return $ FloatExpr x y integerExpr :: Parser EgisonExpr @@ -814,6 +788,9 @@ , "let" , "let*" , "with-symbols" +-- , "not" +-- , "and" +-- , "or" , "loop" , "match-all" , "match" @@ -880,6 +857,7 @@ keywordNot = reserved "not" keywordAnd = reserved "and" keywordOr = reserved "or" +keywordLater = reserved "later" keywordSeq = reserved "seq" keywordApply = reserved "apply" keywordCApply = reserved "capply" @@ -900,10 +878,6 @@ keywordMatchAllLambda = reserved "match-all-lambda" keywordMatch = reserved "match" keywordMatchLambda = reserved "match-lambda" -keywordNextMatchAll = reserved "next-match-all" -keywordNextMatchAllLambda = reserved "next-match-all-lambda" -keywordNextMatch = reserved "next-match" -keywordNextMatchLambda = reserved "next-match-lambda" keywordMatcher = reserved "matcher" keywordMatcherDFS = reserved "matcher-dfs" keywordDo = reserved "do" @@ -955,10 +929,14 @@ stringLiteral :: Parser String stringLiteral = P.stringLiteral lexer ---charLiteral :: Parser Char ---charLiteral = P.charLiteral lexer charLiteral :: Parser Char -charLiteral = string "c#" >> anyChar +charLiteral = P.charLiteral lexer + +oneChar :: Parser Char +oneChar = do + string "c#" + x <- (char '\\' >> anyChar >>= (\x -> return ['\\', x])) <|> (anyChar >>= (\x -> return [x])) + return $ doParse' charLiteral $ "'" ++ x ++ "'" boolLiteral :: Parser Bool boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False) 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 @@ -124,6 +124,10 @@ fromParsecError :: ParseError -> EgisonError fromParsecError = Parser . show +doParse' :: Parser a -> String -> a +doParse' p input = case doParse p input of + Right x -> x + -- -- Expressions -- @@ -142,7 +146,7 @@ <|> try (do (VarWithIndices name is) <- identVarWithIndices inSpaces $ string "=" >> notFollowedBy (string "=") body <- expr - return $ Define (Var name (map f is)) (WithSymbolsExpr (map g is) (TransposeExpr (CollectionExpr (map (ElementExpr . h) is)) body))) + return $ Define (Var name (map f is)) (WithSymbolsExpr (map g is) (TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) body))) where argNames' :: Parser [Arg] argNames' = sepEndBy argName' comma @@ -156,9 +160,6 @@ g (Superscript i) = i g (Subscript i) = i g (SupSubscript i) = i - h (Superscript i) = (VarExpr $ stringToVar i) - h (Subscript i) = (VarExpr $ stringToVar i) - h (SupSubscript i) = (VarExpr $ stringToVar i) testExpr :: Parser EgisonTopExpr testExpr = keywordTest >> Test <$> parens expr @@ -190,7 +191,7 @@ , [binary "+" "+" AssocLeft, binary "-" "-" AssocLeft, binary "%" "remainder" AssocLeft] , [binary "==" "eq?" AssocLeft, binary "<=" "lte?" AssocLeft, binary "<" "lt?" AssocLeft, binary ">=" "gte?" AssocLeft, binary ">" "gt?" AssocLeft] , [binary ":" "cons" AssocLeft, binary ".." "between" AssocLeft] - , [binary "and" "and" AssocLeft, binary "or" "or" AssocLeft] + , [binary "&&" "and" AssocLeft, binary "||" "or" AssocLeft] , [binary "++" "join" AssocRight] ] unary "-" assoc = Prefix (try $ inSpaces (string "-") >> (return $ \x -> (makeApply (VarExpr $ stringToVar "*") [IntegerExpr (-1), x]))) @@ -279,7 +280,7 @@ freshVarExpr = char '#' >> return FreshVarExpr inductiveDataExpr :: Parser EgisonExpr -inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy expr whiteSpace +inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy term whiteSpace tupleExpr :: Parser EgisonExpr tupleExpr = parens $ TupleExpr <$> sepEndBy expr comma @@ -356,8 +357,8 @@ ppPattern :: Parser PrimitivePatPattern ppPattern = P.lexeme lexer (ppWildCard + <|> try ppValuePat <|> ppPatVar - <|> ppValuePat <|> ppInductivePat "primitive-pattren-pattern") @@ -368,7 +369,7 @@ ppPatVar = reservedOp "$" *> pure PPPatVar ppValuePat :: Parser PrimitivePatPattern -ppValuePat = reservedOp ",$" >> PPValuePat <$> ident +ppValuePat = reservedOp "$" >> PPValuePat <$> ident ppInductivePat :: Parser PrimitivePatPattern ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace) @@ -382,7 +383,7 @@ <|> brackets ((PDConsPat <$> pdPattern <* comma <*> (char '@' *> pdPattern)) <|> (PDSnocPat <$> (char '@' *> pdPattern) <* comma <*> pdPattern) <|> pure PDEmptyPat) - <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern comma) + <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern whiteSpace) <|> parens (PDTuplePat <$> sepEndBy pdPattern comma) <|> PDConstantPat <$> constantExpr "primitive-data-pattern" @@ -443,14 +444,14 @@ binding = (,) <$> varNames' <* inSpaces (string "=") <*> expr varNames :: Parser [String] -varNames = sepEndBy (char '$' >> ident) spaces +varNames = sepEndBy (char '$' >> ident) whiteSpace varNames' :: Parser [Var] varNames' = return <$> identVar <|> parens (sepEndBy identVar comma) argNames :: Parser [Arg] -argNames = sepEndBy argName spaces +argNames = sepEndBy argName whiteSpace argName :: Parser Arg argName = try (char '$' >> ident >>= return . ScalarArg) @@ -653,12 +654,7 @@ loopPat = keywordLoop >> parens (char '$' >> LoopPat <$> identVarWithoutIndex <*> (comma >> loopRange) <*> (comma >> pattern) <*> (comma >> option (NotPat WildCard) pattern)) loopRange :: Parser LoopRange -loopRange = brackets (try (do s <- expr - comma - e <- expr - comma - ep <- option WildCard pattern - return (LoopRange s e ep)) +loopRange = parens (try (LoopRange <$> expr <* comma <*> expr <*> option WildCard (comma >> pattern)) <|> (do s <- expr comma ep <- option WildCard pattern @@ -683,7 +679,7 @@ "constant" charExpr :: Parser EgisonExpr -charExpr = CharExpr <$> charLiteral +charExpr = CharExpr <$> oneChar stringExpr :: Parser EgisonExpr stringExpr = StringExpr . T.pack <$> stringLiteral @@ -693,15 +689,9 @@ floatExpr :: Parser EgisonExpr floatExpr = do - (x,y) <- try (do x <- floatLiteral' - y <- sign' <*> positiveFloatLiteral - char 'i' - return (x,y)) - <|> try (do y <- floatLiteral' - char 'i' - return (0,y)) - <|> try (do x <- floatLiteral' - return (x,0)) + (x,y) <- try ((,) <$> floatLiteral' <*> (sign' <*> positiveFloatLiteral) <* char 'i') + <|> try ((,) 0 <$> floatLiteral' <* char 'i') + <|> try (flip (,) 0 <$> floatLiteral') return $ FloatExpr x y integerExpr :: Parser EgisonExpr @@ -806,7 +796,6 @@ reservedOperators :: [String] reservedOperators = [ "$" - , ",$" , "_" , "^" , "&" @@ -898,10 +887,14 @@ stringLiteral :: Parser String stringLiteral = P.stringLiteral lexer ---charLiteral :: Parser Char ---charLiteral = P.charLiteral lexer charLiteral :: Parser Char -charLiteral = string "c#" >> anyChar +charLiteral = P.charLiteral lexer + +oneChar :: Parser Char +oneChar = do + string "c#" + x <- (char '\\' >> anyChar >>= (\x -> return ['\\', x])) <|> (anyChar >>= (\x -> return [x])) + return $ doParse' charLiteral $ "'" ++ x ++ "'" boolLiteral :: Parser Bool boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False) 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 @@ -256,11 +256,6 @@ | MatchLambdaExpr EgisonExpr [MatchClause] | MatchAllLambdaExpr EgisonExpr [MatchClause] - | NextMatchExpr EgisonExpr EgisonExpr [MatchClause] - | NextMatchAllExpr EgisonExpr EgisonExpr MatchClause - | NextMatchLambdaExpr EgisonExpr [MatchClause] - | NextMatchAllLambdaExpr EgisonExpr MatchClause - | MatcherExpr MatcherInfo | MatcherDFSExpr MatcherInfo | AlgebraicDataMatcherExpr [(String, [EgisonExpr])] @@ -338,6 +333,7 @@ | PredPat EgisonExpr | IndexedPat EgisonPattern [EgisonExpr] | LetPat [BindingExpr] EgisonPattern + | LaterPat EgisonPattern | NotPat EgisonPattern | AndPat [EgisonPattern] | OrPat [EgisonPattern] @@ -1211,6 +1207,7 @@ show (ApplyExpr fn (TupleExpr args)) = "(" ++ show fn ++ " " ++ unwords (map show args) ++ ")" show (ApplyExpr fn arg) = "(" ++ show fn ++ " " ++ show arg ++ ")" show (VectorExpr xs) = "[| " ++ unwords (map show xs) ++ " |]" + show (WithSymbolsExpr xs e) = "(withSymbols {" ++ unwords (map show xs) ++ "} " ++ show e ++ ")" show _ = "(not supported)" instance Show EgisonValue where @@ -1646,7 +1643,8 @@ topDFS :: EgisonPattern -> Bool topDFS (DFSPat _ _) = True -topDFS (InductivePat _ patterns) = any topDFS patterns +topDFS (InductivePat _ (pattern:_)) = topDFS pattern +topDFS (LetPat _ pattern) = topDFS pattern topDFS _ = False containBFS :: EgisonPattern -> Bool @@ -1666,6 +1664,7 @@ containBFS (MultPat patterns) = any containBFS patterns containBFS (PowerPat pat1 pat2) = containBFS pat1 || containBFS pat2 containBFS (DFSPat _ pattern) = containBFS pattern +containBFS (LetPat _ pattern) = containBFS pattern containBFS _ = False -- diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -574,7 +574,7 @@ [(map (lambda [$i] x_i) (between 1 n)) tgt]])]}] [,$val [] - {[$tgt (match [val tgt] [(list a) (multiset a)] + {[$tgt (match [(unique val) (unique tgt)] [(list a) (multiset a)] {[[ ] {[]}] [[ ] {[]}] [[_ _] {}]})]}] @@ -593,7 +593,7 @@ (define $unique (lambda [$xs] (reverse (match-all (reverse xs) (list something) - [>>> x])))) + [>>> x])))) (define $unique/m (lambda [$a $xs] diff --git a/sample/n-queen.egi b/sample/n-queen.egi --- a/sample/n-queen.egi +++ b/sample/n-queen.egi @@ -55,6 +55,10 @@ )> a]))) +(test (n-queen 4)) +(test (n-queen 5)) +(test (n-queen 6)) +(test (n-queen 7)) (test (n-queen 8)) (test (n-queen 9)) (test (n-queen 10))