egison 3.2.24 → 3.3.0
raw patch · 12 files changed
+81/−127 lines, 12 files
Files
- egison.cabal +1/−1
- hs-src/Language/Egison/Core.hs +31/−41
- hs-src/Language/Egison/Desugar.hs +7/−6
- hs-src/Language/Egison/Parser.hs +8/−14
- hs-src/Language/Egison/Types.hs +3/−7
- lib/core/collection.egi +8/−41
- lib/core/natural-number.egi +1/−1
- sample/graph.egi +2/−2
- sample/n-queen.egi +2/−2
- sample/one-minute-first.egi +9/−0
- sample/one-minute-second.egi +5/−0
- sample/sequence.egi +4/−12
egison.cabal view
@@ -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.
hs-src/Language/Egison/Core.hs view
@@ -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
hs-src/Language/Egison/Desugar.hs view
@@ -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
hs-src/Language/Egison/Parser.hs view
@@ -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"
hs-src/Language/Egison/Types.hs view
@@ -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) --
lib/core/collection.egi view
@@ -25,7 +25,7 @@ [<join ,$pxs $> [(list a)] {[$tgt (match-all [pxs tgt] [(list a) (list a)] [[(loop $i [1 $n] <cons $xa_i ...> <nil>)- (loop $i [1 ,n] <cons ,xa_i ...> $rs)]+ (loop $i [1 n] <cons ,xa_i ...> $rs)] rs])]}] [<join $ $> [(list a) (list a)] {[$tgt (match-all tgt (list a)@@ -33,7 +33,7 @@ [<nioj ,$pxs $> [(list a)] {[$tgt (match-all [pxs tgt] [(list a) (list a)] [[(loop $i [1 $n] <snoc $xa_i ...> <nil>)- (loop $i [1 ,n] <snoc ,xa_i ...> $rs)]+ (loop $i [1 n] <snoc ,xa_i ...> $rs)] rs])]}] [<nioj $ $> [(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)]- {[[<nil> <nil>] {[]}]- [[<cons $x $xs> <cons ,x ,xs>] {[]}]- [[_ _] {}]})]}]- [<nil> []- {[{} {[]}]- [_ {}]}]- [<cons $ $> [a (flist a)]- {[{$x @$xs} {[x xs]}]- [_ {}]}]- [<snoc $ $> [a (flist a)]- {[{@$xs $x} {[x xs]}]- [_ {}]}]- [<join ,$pxs $> [(flist a)]- {[$tgt (match-all [pxs tgt] [(flist a) (flist a)]- [[(loop $i [1 $n] <cons $xa_i ...> <nil>)- (loop $i [1 ,n] <cons ,xa_i ...> $rs)]- rs])]}]- [<join $ $> [(flist a) (flist a)]- {[$tgt (match-all tgt (flist a)- [(loop $i [1 $n] <cons $xa_i ...> $rs) [(map (lambda [$i] xa_i) (between 1 n)) rs]])]}]- [<nioj ,$pxs $> [(flist a)]- {[$tgt (match-all [pxs tgt] [(flist a) (flist a)]- [[(loop $i [1 $n] <snoc $xa_i ...> <nil>)- (loop $i [1 ,n] <snoc ,xa_i ...> $rs)]- rs])]}]- [<nioj $ $> [(flist a) (flist a)]- {[$tgt (match-all tgt (flist a)- [(loop $i [1 $n] <snoc $xa_i ...> $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)] <cons _ ...> <cons $x _>) x]})))@@ -265,7 +232,7 @@ (define $take-and-drop (lambda [$n $xs] (match xs (list something)- {[(loop $i [1 ,n] <cons $a_i ...> $rs)+ {[(loop $i [1 n] <cons $a_i ...> $rs) [(map (lambda [$i] a_i) (between 1 n)) rs]]}))) (define $take
lib/core/natural-number.egi view
@@ -92,7 +92,7 @@ (define $pfs-n (lambda [$n] (match-all p-fs (list [integer (list integer)])- [<join _ <cons [$m (loop $i [1 ,n] <cons $p_i ...> <nil>)] _>> [m (map (lambda [$i] p_i) (between 1 n))]])))+ [<join _ <cons [$m (loop $i [1 n] <cons $p_i ...> <nil>)] _>> [m (map (lambda [$i] p_i) (between 1 n))]]))) (define $prime? (lambda [$n]
sample/graph.egi view
@@ -76,9 +76,9 @@ (test (let {[$n 3]} (match-all graph-data2 (graph integer) [<cons <edge $x_1 $x_2>- (loop $i [3 ,n]+ (loop $i [3 n] <cons <edge ,x_1 $x_i>- (loop $j [2 ,(- i 1)]+ (loop $j [2 (- i 1)] <cons <edge ,x_j ,x_i> ...> ...) _>
sample/n-queen.egi view
@@ -45,8 +45,8 @@ (lambda [$n] (match-all (between 1 n) (multiset integer) [<cons $a_1- (loop $i [2 ,n]- <cons (loop $i1 [1 ,(- i 1)]+ (loop $i [2 n]+ <cons (loop $i1 [1 (- i 1)] (& ^,(- a_i1 (- i i1)) ^,(+ a_i1 (- i i1)) ...)
+ sample/one-minute-first.egi view
@@ -0,0 +1,9 @@+; enumerate the elements of the collection that appear twice+(test (match-all {1 2 3 4 3 5 2 6} (multiset integer) [<cons $x <cons ,x _>> x]))++; enumerate the elements of the collection that appear only once+(test (match-all {1 2 3 4 3 5 2 6} (multiset integer) [<cons $x ^<cons ,x _>> 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) [<cons $x <cons ,(+ x 1) <cons ,(+ x 2) _>>> x]))+
+ sample/one-minute-second.egi view
@@ -0,0 +1,5 @@+; enumerate first 100 pairs of numbers+(test (take 100 (match-all nats (set integer) [<cons $x <cons $y _>> [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) [<join _ <cons $p <cons ,(+ p 2) _>>> [p (+ p 2)]])))
sample/sequence.egi view
@@ -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) [<join _ <cons $p <cons ,(+ p 2) _>>> [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)]- [[<cons $c _> <cons ,c _>]- c]))) -; test 'commons'-(test (commons (take 100 primes) (take 300 pyths)))