diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.2.24 +Version: 3.3.0 Synopsis: Programming language with non-linear pattern-matching against unfree data types Description: An interpreter for Egison, the programming langugage that realized non-linear pattern-matching against unfree data types. 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 @@ -539,39 +539,36 @@ in return $ msingleton $ MState env loops bindings (MNode penv (MState env'' [] [] [MAtom expr target matcher]) : trees) _ -> throwError $ TypeMismatch "pattern constructor" func' - LoopPat loopMode name (LoopRange start endPat) pat pat' -> do + LoopPat name (LoopRange start ends endPat) pat pat' -> do startNum <- evalExpr env' start >>= fromWHNF startNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum - 1) - return $ msingleton $ MState env ((LoopContext loopMode (name, startNumRef) (False, endPat) pat pat'):loops) bindings ((MAtom ContPat target matcher):trees) + ends' <- evalExpr env' ends + if isPrimitiveValue ends' + then do + endsRef <- newEvalutedObjectRef ends' + inners <- liftIO $ newIORef $ Sq.fromList [IElement endsRef] + endsRef' <- liftIO $ newIORef (WHNF (Intermediate (ICollection inners))) + return $ msingleton $ MState env ((LoopContext (name, startNumRef) endsRef' endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees) + else do + endsRef <- newEvalutedObjectRef ends' + return $ msingleton $ MState env ((LoopContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees) ContPat -> case loops of [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern" - LoopContext SmartMode (name, startNumRef) (matched, endPat) pat pat' : loops' -> do - startNum <- evalRef startNumRef >>= fromWHNF - nextNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum + 1) - let (carPat, mCdrPat) = unconsOrPattern endPat - matches <- patternMatch env' carPat startNumRef Something - case (matched, matches) of - (False, MNil) -> return $ msingleton $ MState env ((LoopContext SmartMode (name, nextNumRef) (False, endPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees) - (True, MNil) -> case mCdrPat of - Nothing -> return MNil - Just cdrPat -> do - let (carPat', _) = unconsOrPattern cdrPat - matches' <- patternMatch env' carPat' startNumRef Something - case matches' of - MNil -> return $ msingleton $ MState env ((LoopContext SmartMode (name, nextNumRef) (False, cdrPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees) - MCons _ _ -> do - return $ fromList [MState env loops' bindings ((MAtom cdrPat startNumRef Something):(MAtom pat' target matcher):trees), - MState env ((LoopContext SmartMode (name, nextNumRef) (True, cdrPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees)] - (_, MCons _ _) -> do - return $ fromList [MState env loops' bindings ((MAtom endPat startNumRef Something):(MAtom pat' target matcher):trees), - MState env ((LoopContext SmartMode (name, nextNumRef) (True, endPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees)] - LoopContext NaiveMode (name, startNumRef) (matched, endPat) pat pat' : loops' -> do + LoopContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do startNum <- evalRef startNumRef >>= fromWHNF nextNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum + 1) - return $ fromList [MState env loops' bindings ((MAtom endPat startNumRef Something):(MAtom pat' target matcher):trees), - MState env ((LoopContext NaiveMode (name, nextNumRef) (True, endPat) pat pat'):loops') bindings ((MAtom pat target matcher):trees)] - + ends <- evalRef endsRef + b <- isEmptyCollection ends + if b + then return MNil + else do + (carEndsRef, cdrEndsRef) <- fromJust <$> runMaybeT (unconsCollection ends) + carEndsNum <- evalRef carEndsRef >>= fromWHNF + if startNum == carEndsNum + then return $ fromList [MState env loops' bindings ((MAtom endPat startNumRef Something):(MAtom pat' target matcher):trees), + MState env ((LoopContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] + else return $ fromList [MState env ((LoopContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] AndPat patterns -> let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees in return $ msingleton $ MState env loops bindings trees' @@ -770,21 +767,7 @@ unsnocCollection _ = matchFail extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopContext] -> Env -extendEnvForNonLinearPatterns env bindings loops = extendEnv env $ bindings ++ map (\(LoopContext _ binding _ _ _) -> binding) loops - -unconsOrPattern :: EgisonPattern -> (EgisonPattern, Maybe EgisonPattern) -unconsOrPattern (LetPat bindings pat) = let (pat',mpat'') = unconsOrPattern pat in - case mpat'' of - Just pat'' -> (LetPat bindings pat', Just (LetPat bindings pat'')) - Nothing -> (LetPat bindings pat', Nothing) -unconsOrPattern (OrPat [pat]) = (pat, Nothing) -unconsOrPattern (OrPat (pat:pats)) = (pat, Just (OrPat pats)) -unconsOrPattern (AndPat [pat]) = unconsOrPattern pat -unconsOrPattern (AndPat (pat:pats)) = let (pat',mpat'') = unconsOrPattern pat in - case mpat'' of - Just pat'' -> (AndPat (pat':pats), Just (AndPat (pat'':pats))) - Nothing -> (AndPat (pat':pats), Nothing) -unconsOrPattern pat = (pat, Nothing) +extendEnvForNonLinearPatterns env bindings loops = extendEnv env $ bindings ++ map (\(LoopContext binding _ _ _ _) -> binding) loops -- -- Util @@ -859,3 +842,10 @@ extractPrimitiveValue (Value val@(Integer _)) = return val extractPrimitiveValue (Value val@(Float _)) = return val extractPrimitiveValue whnf = throwError $ TypeMismatch "primitive value" whnf + +isPrimitiveValue :: WHNFData -> Bool +isPrimitiveValue (Value (Char _)) = True +isPrimitiveValue (Value (Bool _)) = True +isPrimitiveValue (Value (Integer _)) = True +isPrimitiveValue (Value (Float _)) = True +isPrimitiveValue _ = False 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 @@ -246,7 +246,7 @@ collectName (TuplePat patterns) = collectNames patterns collectName (InductivePat _ patterns) = collectNames patterns collectName (ApplyPat _ patterns) = collectNames patterns - collectName (LoopPat _ _ _ pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 + collectName (LoopPat _ _ pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 collectName (LetPat _ pattern) = collectName pattern collectName (IndexedPat (PatVar name) _) = S.singleton name collectName (OrPat patterns) = collectNames patterns @@ -267,8 +267,8 @@ IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs desugarPattern' (ApplyPat expr patterns) = ApplyPat <$> desugar expr <*> mapM desugarPattern' patterns -desugarPattern' (LoopPat mode name range pattern1 pattern2) = - LoopPat mode name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 +desugarPattern' (LoopPat name range pattern1 pattern2) = + LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' (LetPat binds pattern) = do LetPat <$> desugarBindings binds <*> desugarPattern' pattern desugarPattern' (OrPat patterns) = @@ -276,10 +276,11 @@ desugarPattern' pattern = return pattern desugarLoopRange :: LoopRange -> DesugarM LoopRange -desugarLoopRange (LoopRange expr pattern) = do - expr' <- desugar expr +desugarLoopRange (LoopRange sExpr eExpr pattern) = do + sExpr' <- desugar sExpr + eExpr' <- desugar eExpr pattern' <- desugarPattern pattern - return $ LoopRange expr' pattern' + return $ LoopRange sExpr' eExpr' pattern' desugarBinding :: BindingExpr -> DesugarM BindingExpr desugarBinding (name, expr) = do 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 @@ -384,8 +384,6 @@ <|> orPat <|> applyPat <|> loopPat - <|> naiveLoopPat - <|> smartLoopPat <|> letPat) wildCard :: Parser EgisonPattern @@ -428,16 +426,16 @@ applyPat = ApplyPat <$> expr <*> sepEndBy pattern whiteSpace loopPat :: Parser EgisonPattern -loopPat = keywordLoop >> LoopPat SmartMode <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern - -naiveLoopPat :: Parser EgisonPattern -naiveLoopPat = keywordNaiveLoop >> LoopPat NaiveMode <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern - -smartLoopPat :: Parser EgisonPattern -smartLoopPat = keywordSmartLoop >> LoopPat SmartMode <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern +loopPat = keywordLoop >> LoopPat <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern loopRange :: Parser LoopRange -loopRange = brackets $ LoopRange <$> expr <*> pattern +loopRange = brackets (try (do s <- expr + e <- expr + ep <- option WildCard pattern + return (LoopRange s e ep)) + <|> (do s <- expr + ep <- option WildCard pattern + return (LoopRange s (ApplyExpr (VarExpr "from") (ApplyExpr (VarExpr "-") (TupleExpr [s, (IntegerExpr 1)]))) ep))) -- Constants @@ -512,8 +510,6 @@ , "letrec" , "let" , "loop" - , "naive-loop" - , "smart-loop" , "match-all" , "match" , "match-all-lambda" @@ -562,8 +558,6 @@ keywordLetRec = reserved "letrec" keywordLet = reserved "let" keywordLoop = reserved "loop" -keywordNaiveLoop = reserved "naive-loop" -keywordSmartLoop = reserved "smart-loop" keywordMatchAll = reserved "match-all" keywordMatchAllLambda = reserved "match-all-lambda" keywordMatch = reserved "match" 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 @@ -19,7 +19,6 @@ , BindingExpr (..) , MatchClause (..) , MatcherInfo (..) - , LoopMode (..) , LoopRange (..) , PrimitivePatPattern (..) , PrimitiveDataPattern (..) @@ -191,16 +190,13 @@ | OrPat [EgisonPattern] | TuplePat [EgisonPattern] | InductivePat String [EgisonPattern] - | LoopPat LoopMode String LoopRange EgisonPattern EgisonPattern + | LoopPat String LoopRange EgisonPattern EgisonPattern | ContPat | ApplyPat EgisonExpr [EgisonPattern] | VarPat String deriving (Show) -data LoopMode = NaiveMode | SmartMode - deriving (Show) - -data LoopRange = LoopRange EgisonExpr EgisonPattern +data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern deriving (Show) data PrimitivePatPattern = @@ -526,7 +522,7 @@ type PatternBinding = (Var, EgisonPattern) -data LoopContext = LoopContext LoopMode Binding (Bool, EgisonPattern) EgisonPattern EgisonPattern +data LoopContext = LoopContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern deriving (Show) -- diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -25,7 +25,7 @@ [ [(list a)] {[$tgt (match-all [pxs tgt] [(list a) (list a)] [[(loop $i [1 $n] ) - (loop $i [1 ,n] $rs)] + (loop $i [1 n] $rs)] rs])]}] [ [(list a) (list a)] {[$tgt (match-all tgt (list a) @@ -33,7 +33,7 @@ [ [(list a)] {[$tgt (match-all [pxs tgt] [(list a) (list a)] [[(loop $i [1 $n] ) - (loop $i [1 ,n] $rs)] + (loop $i [1 n] $rs)] rs])]}] [ [(list a) (list a)] {[$tgt (match-all tgt (list a) @@ -42,43 +42,6 @@ {[$tgt {tgt}]}] }))) -(define $flist - (lambda [$a] - (matcher-dfs - {[,$val [] - {[$tgt (match [val tgt] [(flist a) (flist a)] - {[[ ] {[]}] - [[ ] {[]}] - [[_ _] {}]})]}] - [ [] - {[{} {[]}] - [_ {}]}] - [ [a (flist a)] - {[{$x @$xs} {[x xs]}] - [_ {}]}] - [ [a (flist a)] - {[{@$xs $x} {[x xs]}] - [_ {}]}] - [ [(flist a)] - {[$tgt (match-all [pxs tgt] [(flist a) (flist a)] - [[(loop $i [1 $n] ) - (loop $i [1 ,n] $rs)] - rs])]}] - [ [(flist a) (flist a)] - {[$tgt (match-all tgt (flist a) - [(loop $i [1 $n] $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}] - [ [(flist a)] - {[$tgt (match-all [pxs tgt] [(flist a) (flist a)] - [[(loop $i [1 $n] ) - (loop $i [1 ,n] $rs)] - rs])]}] - [ [(flist a) (flist a)] - {[$tgt (match-all tgt (flist a) - [(loop $i [1 $n] $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}] - [$ [something] - {[$tgt {tgt}]}] - }))) - (define $string (list char)) ;; @@ -99,6 +62,10 @@ {s (+ s 1) (+ s 2) (+ s 3) (+ s 4) (+ s 5) (+ s 6) (+ s 7) (+ s 8) (+ s 9) (+ s 10) @(between (+ s 11) e)}) )) +(define $from + (lambda [$s] + {s (+ s 1) (+ s 2) (+ s 3) (+ s 4) (+ s 5) (+ s 6) (+ s 7) (+ s 8) (+ s 9) (+ s 10) @(from (+ s 11))})) + ;; ;; list functions ;; @@ -257,7 +224,7 @@ (define $nth (lambda [$n $xs] (match xs (list something) - {[(loop $i [1 ,(- n 1)] + {[(loop $i [1 (- n 1)] ) x]}))) @@ -265,7 +232,7 @@ (define $take-and-drop (lambda [$n $xs] (match xs (list something) - {[(loop $i [1 ,n] $rs) + {[(loop $i [1 n] $rs) [(map (lambda [$i] a_i) (between 1 n)) rs]]}))) (define $take diff --git a/lib/core/natural-number.egi b/lib/core/natural-number.egi --- a/lib/core/natural-number.egi +++ b/lib/core/natural-number.egi @@ -92,7 +92,7 @@ (define $pfs-n (lambda [$n] (match-all p-fs (list [integer (list integer)]) - [ )] _>> [m (map (lambda [$i] p_i) (between 1 n))]]))) + [ )] _>> [m (map (lambda [$i] p_i) (between 1 n))]]))) (define $prime? (lambda [$n] diff --git a/sample/graph.egi b/sample/graph.egi --- a/sample/graph.egi +++ b/sample/graph.egi @@ -76,9 +76,9 @@ (test (let {[$n 3]} (match-all graph-data2 (graph integer) [ - (loop $i [3 ,n] + (loop $i [3 n] - (loop $j [2 ,(- i 1)] + (loop $j [2 (- i 1)] ...> ...) _> diff --git a/sample/n-queen.egi b/sample/n-queen.egi --- a/sample/n-queen.egi +++ b/sample/n-queen.egi @@ -45,8 +45,8 @@ (lambda [$n] (match-all (between 1 n) (multiset integer) [> x])) + +; enumerate the elements of the collection that appear only once +(test (match-all {1 2 3 4 3 5 2 6} (multiset integer) [> x])) + +; enumerate the elements of the collection if all of the three consecutive numbers from it are contained in the collection. +(test (match-all {1 2 13 14 3 15 2 6} (multiset integer) [>> x])) + diff --git a/sample/one-minute-second.egi b/sample/one-minute-second.egi new file mode 100644 --- /dev/null +++ b/sample/one-minute-second.egi @@ -0,0 +1,5 @@ +; enumerate first 100 pairs of numbers +(test (take 100 (match-all nats (set integer) [> [x y]]))) + +; enumerate first 100 twin primes using non-linear patterns against the infinite list of prime numbers +(test (take 100 (match-all primes (list integer) [>> [p (+ p 2)]]))) diff --git a/sample/sequence.egi b/sample/sequence.egi --- a/sample/sequence.egi +++ b/sample/sequence.egi @@ -15,18 +15,10 @@ ; test 'pairs' (test (take 100 pairs)) -; infinite list of pythagoras numbers -(define $pyths (map (lambda [$m $n] (+ (power m 2) (power n 2))) pairs)) +; first 100 prime numbers +(test (take 100 primes)) -; test 'pyths' -(test (take 100 pyths)) +; enumerate first 100 twin primes +(test (take 100 (match-all primes (list integer) [>> [p (+ p 2)]]))) -; function that enumerates all common elements between two lists -(define $commons - (lambda [$xs $ys] - (match-all [xs ys] [(multiset integer) (multiset integer)] - [[ ] - c]))) -; test 'commons' -(test (commons (take 100 primes) (take 300 pyths)))