egison 2.4.0 → 2.4.1
raw patch · 5 files changed
+114/−56 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- egison.cabal +1/−1
- hs-src/Language/Egison/Core.hs +4/−4
- lib/core/collection.egi +83/−45
- sample/collection-test.egi +23/−3
- sample/graph-test.egi +3/−3
egison.cabal view
@@ -1,5 +1,5 @@ Name: egison-Version: 2.4.0+Version: 2.4.1 Synopsis: An Interpreter for the Programming Language Egison Description: An interpreter for the programming language Egison. A feature of Egison is the strong pattern match facility.
hs-src/Language/Egison/Core.hs view
@@ -505,12 +505,12 @@ let tgtObjRefs = [tgtObjRef] if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs) then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states- else throwError $ Default "patternMatch: number of types, patterns and targets are different"+ else throwError $ Default "patternMatch(ITuple-1): number of types, patterns and targets are different" else do tgtObjRefs <- tupleToObjRefs tgtObjRef if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs) then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states- else throwError $ Default "patternMatch: number of types, patterns and targets are different"+ else throwError $ Default "patternMatch(ITuple): number of types, patterns and targets are different" Value (Tuple pats) -> do patObjRefs <- liftIO $ mapM (newIORef . Value) pats typObjRefs <- tupleToObjRefs typObjRef@@ -519,12 +519,12 @@ let tgtObjRefs = [tgtObjRef] if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs) then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states- else throwError $ Default "patternMatch: number of types, patterns and targets are different"+ else throwError $ Default "patternMatch(Tuple-1): number of types, patterns and targets are different" else do tgtObjRefs <- tupleToObjRefs tgtObjRef if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs) then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states- else throwError $ Default "patternMatch: number of types, patterns and targets are different"+ else throwError $ Default "patternMatch(Tuple): number of types, patterns and targets are different" Value (PredPat predObjRef patObjRefs) -> do argsObjRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ patObjRefs ++ [tgtObjRef] ret <- cApply1 predObjRef argsObjRef
lib/core/collection.egi view
@@ -35,20 +35,20 @@ (helper pys tgt))]}] [<join _ _> [(List a) (List a)] {[$tgt (letrec {[$helper (lambda [$xs $ys]- (match ys (List a)- {[<nil> {[xs {}]}]- [<cons $z $zs> {[xs ys] @(helper {@xs z} zs {[xs ys]})}]}))]}- (helper {} tgt))]}]+ (match ys (List a)+ {[<nil> {[xs {}]}]+ [<cons $z $zs> {[xs ys] @(helper {@xs z} zs)}]}))]}+ (helper {} tgt))]}] [<nioj ,$pxs _> [(List a)] {[$tgt (match-all tgt (List a) [<join $ys ,pxs> ys])]}] [<nioj _ ,$pys> [(List a)] {[$tgt (match-all tgt (List a) [<join ,pys $xs> xs])]}] [<nioj _ _> [(List a) (List a)]- {[$tgt (letrec {[$helper (lambda [$xs $ys]- (match ys (List a)- {[<nil> {[{} xs]}]- [<cons $z $zs> {[ys xs] @(helper {@xs z} zs)}]}))]}- (helper {} tgt {}))]}]+ {[$tgt (letrec {[$helper (lambda [$xs $ys]+ (match ys (List a)+ {[<nil> {[{} xs]}]+ [<cons $z $zs> {[ys xs] @(helper {@xs z} zs)}]}))]}+ (helper {} tgt))]}] [_ [Something] {[$tgt {tgt}]}] })))@@ -59,6 +59,12 @@ {[<nil> {}] [<cons $x $xs> {(fn x) @(map fn xs)}]}))) +(define $map&concat+ (lambda [$fn $ls]+ (match ls (List Something)+ {[<nil> {}]+ [<cons $x $xs> {@(fn x) @(map&concat fn xs)}]})))+ (define $foldr (lambda [$fn $init $ls] (match ls (List Something)@@ -118,14 +124,35 @@ {[<nil> xs] [<cons $y $rs> ((union a) ((add a) xs y) rs)]})))) +(define $occurence+ (lambda [$a]+ (lambda [$xs]+ (letrec+ {[$remove&count (lambda [$x $xs]+ (match xs (List a)+ {[<nil> [{} 1]]+ [<cons ,x $ys> (let {[[$r $i] (remove&count x ys)]}+ [r (+ i 1)])]+ [<cons $y $ys> (let {[[$r $i] (remove&count x ys)]}+ [{y @r} i])]}))]}+ (match xs (List Something)+ {[<nil> {}]+ [<cons $x $ys> (let {[[$rs $i] (remove&count x ys)]}+ {[x i] @((occurence a) rs)})]})))))+ (define $subcollections- (lambda [$xs]- (match xs (List Something)- {[<nil> {{}}]- [<cons $x $rs>- (let {[$subs (subcollections rs)]} - {@subs @(map (lambda [$sub] {x @sub}) subs)})]})))+ (lambda [$a]+ (lambda [$xs]+ (foldr+ (lambda [$x $rs]+ (let {[[$y $i] x]} + (map&concat (lambda [$sub] + (match-all (loop $l $j (between 1 i) {y @l} {}) (List a) [<join $ys _> {@ys @sub}]))+ rs)))+ {{}}+ ((occurence a) xs))))) + (define $size (lambda [$xs] (match xs (List Something)@@ -201,41 +228,52 @@ (define $Multiset (lambda [$a] (type- {[,$val []+ {[,$val [] {[$tgt (match [val tgt] [(List a) (Multiset a)] {[[<nil> <nil>] {[]}]- [[<cons $x $xs> <cons ,x ,xs>] {[]}]- [[_ _] {}]})]}]- [<nil> []+ [[<cons $x $xs> <cons ,x ,xs>] {[]}]+ [[_ _] {}]})]}]+ [<nil> [] {[{} {[]}] [_ {}]}]- [<cons ,$px _> [(Multiset a)]+ [<cons ,$px _> [(Multiset a)]+ {[$tgt (if ((member? a) px tgt)+ {((remove a) tgt px)}+ {})]}]+ [<cons _ _> [a (Multiset a)] {[$tgt (letrec {[$helper (lambda [$xs $ys]- (match xs (List a)- {[<nil> {}]- [<cons ,px $zs> {{@ys @zs}}]- [<cons $z $zs> (helper zs {@ys z})]}))]}- (helper tgt {}))]}]- [<cons _ _> [a (Multiset a)]+ (match ys (List a)+ {[<nil> {}]+ [<cons $z $zs> (if ((member? a) z xs)+ (helper {@xs z} zs)+ {[z {@xs @zs}] @(helper {@xs z} zs)})]}))]}+ (helper {} tgt))]}]+ [<join ,$pxs _> [(Multiset a)] {[$tgt (letrec {[$helper (lambda [$xs $ys]- (match ys (List a)- {[<nil> {}]- [<cons $z $zs> (if ((member? a) z xs)- (helper {@xs z} zs)- {[z {@xs @zs}] @(helper {@xs z} zs)})]}))]}- (helper {} tgt))]}]- [<join ,$pxs _> [(Multiset a)]- {[$tgt (if ((subcollection? a) pxs tgt)- {((remove-collection a) tgt pxs)}- {})]}]- [<join _ ,$pys> [(Multiset a)]+ (match xs (List Something)+ {[<nil> ys]+ [<cons $z $zs> (if ((member? a) z ys)+ (helper zs ((remove a) ys z))+ {})]}))]}+ {(helper pxs tgt)})]}]+ [<join _ ,$pys> [(Multiset a)] {[$tgt (match-all tgt (Multiset a) [<join ,pys $xs> xs])]}]- [<join _ _> [(Multiset a) (Multiset a)]- {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])- (subcollections tgt))]}]- [_ [Something]+ [<join _ _> [(Multiset a) (Multiset a)]+ {[$tgt+ (foldr+ (lambda [$xi $xs]+ (let {[[$x $i] xi]}+ (map&concat+ (lambda [$sub] + (do {[[$ys $zs] sub]+ [$zs ((remove-all a) zs x)]}+ (match-all (loop $l $j (between 1 i) {x @l} {}) (List a) [<join $us $vs> [{@us @ys} {@zs @vs}]])))+ xs)))+ {[{} tgt]}+ ((occurence a) tgt))]}]+ [_ [Something] {[$tgt {tgt}]}]- })))+ }))) (define $Set (lambda [$a]@@ -265,9 +303,9 @@ (helper tgt2 {})))]}] [<join _ _> [(Set a) (Set a)] {[$tgt (let {[$tgt2 ((unique a) tgt)]}- (concat (map (lambda [$xs $ys] (map (lambda [$sxs] [xs {@ys @sxs}])- (subcollections xs)))- (match-all tgt2 (Multiset a) [<join $xs $ys> [xs ys]]))))]}]+ (map&concat (lambda [$xs $ys] (map (lambda [$sxs] [xs {@ys @sxs}])+ ((subcollections a) xs)))+ (match-all tgt2 (Multiset a) [<join $xs $ys> [xs ys]])))]}] [_ [Something] {[$tgt {tgt}]}] })))
sample/collection-test.egi view
@@ -2,17 +2,22 @@ ;; match List (test (match-all {1 2 3 4 5} (List Integer) [<snoc $x $xs> [x xs]]))+(test {[5 {1 2 3 4}]}) (test (match-all {1 2 3 4 5} (List Integer) [<join ,{1 2} $xs> xs]))+(test {{3 4 5}}) -(test (match-all {1 2 3 4 5} (List Integer) [<join ,{1 2} $xs> xs]))+(test (match-all {1 2 3 4 5} (List Integer) [<join _ <join $xs _>> xs]))+(test {{} {1} {1 2} {1 2 3} {1 2 3 4} {1 2 3 4 5} {} {2} {2 3} {2 3 4} {2 3 4 5} {} {3} {3 4} {3 4 5} {} {4} {4 5} {} {5} {}}) (test (match-all {[1 2] [1 2]} (List [Integer Integer]) [<cons [$a $b] _> [a b]]))+(test {[1 2]}) ;; match Multiset (test (match-all {1 2 3 4 5} (Multiset Integer) [<cons $m <cons $n _>> [m n]]))+(test {[1 2] [1 3] [1 4] [1 5] [2 1] [2 3] [2 4] [2 5] [3 1] [3 2] [3 4] [3 5] [4 1] [4 2] [4 3] [4 5] [5 1] [5 2] [5 3] [5 4]}) ;; match a collection of collections (test (match-all {{1 2 3} {11} {21 22}} (List (Multiset Integer))@@ -21,6 +26,7 @@ <cons <cons $z _> <nil>>>> [x y z]]))+(test {[1 11 21] [1 11 22] [2 11 21] [2 11 22] [3 11 21] [3 11 22]}) ;; match a collection of collections with value patterns (test (match-all {{1 2 3 4 5} {4 5 1} {6 1 7 4}} (List (Multiset Integer))@@ -29,26 +35,30 @@ <cons <cons ,n _> <nil>>>> n]))+(test {1 4}) ;; pattern as first class object (test (let {[$pat <cons ,1 <nil>>]} (match {1} (Multiset Integer) {[pat <ok>] [_ <not-ok>]})))-+(test <ok>)+ ;; Or-pattern test1 (test (match {} (Multiset Integer) {[(| <nil> <cons ,1 <nil>>) <ok>] [_ <not-ok>]}))+(test <ok>) ;; Or-pattern test2 (test (match {1} (Multiset Integer) {[(| <nil> <cons ,1 <nil>>) <ok>] [_ <not-ok>]}))-+(test <ok>) (test (match-all {1 2 3 4 5 6 7 1 3 5 7} (Multiset Integer) [<cons $x ^<cons ,x _>> x]))+(test {2 4 6}) (test (match-all {{1 2 3} {2 3 4} {1}} (Multiset (Multiset Integer)) [<cons <cons $x ^<cons ,x _>>@@ -56,27 +66,35 @@ <cons ^<cons ,x _> <nil>>>> x]))+(test {4 4}) ; is really ok? (test (match-all {{1 2 3} {2 3 4}} (Multiset (Multiset Integer)) [<cons <cons $x ^<cons ,x _>> <cons ^<cons ,x _> <nil>>> x]))+(test {1 4}) (test (match-all {1 2 3} (List Integer) [<join $hs $ts> [hs ts]]))+(test "here")+(test {[{} {1 2 3}] [{1} {2 3}] [{1 2} {3}] [{1 2 3} {}]}) (test (match-all {1 2 3} (List Integer) [<nioj $hs $ts> [hs ts]]))+(test {[{1 2 3} {}] [{2 3} {1}] [{3} {1 2}] [{} {1 2 3}]}) (test (match-all {1 2 3} (Multiset Integer) [<join $hs $ts> [hs ts]]))+(test {[{} {3 2 1}] [{1} {3 2}] [{2} {3 1}] [{1 2} {3}] [{3} {2 1}] [{1 3} {2}] [{2 3} {1}] [{1 2 3} {}]}) (test (match-all {1 2 3} (Set Integer) [<join $hs $ts> [hs ts]]))+(test {[{} {3 2 1}] [{1} {3 2}] [{1} {3 2 1}] [{2} {3 1}] [{2} {3 1 2}] [{1 2} {3}] [{1 2} {3 1}] [{1 2} {3 2}] [{1 2} {3 1 2}] [{3} {2 1}] [{3} {2 1 3}] [{1 3} {2}] [{1 3} {2 1}] [{1 3} {2 3}] [{1 3} {2 1 3}] [{2 3} {1}] [{2 3} {1 2}] [{2 3} {1 3}] [{2 3} {1 2 3}] [{1 2 3} {}] [{1 2 3} {1}] [{1 2 3} {2}] [{1 2 3} {1 2}] [{1 2 3} {3}] [{1 2 3} {1 3}] [{1 2 3} {2 3}] [{1 2 3} {1 2 3}]}) (test (match-all {1 2 3} (List Integer) [<join $hs <cons $x $ts>> [hs x ts]]))+(test {[{} 1 {2 3}] [{1} 2 {3}] [{1 2} 3 {}]}) ;; noij (test (match-all {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))@@ -117,6 +135,7 @@ (test (match-all {1 2 3 1 2} (Multiset Integer) [(single %k _) k]))+(test {1 2 3}) (define $pair (macro [$s $pat]@@ -124,6 +143,7 @@ (test (match-all {1 2 3 1 2} (Multiset Integer) [(pair %k _) k]))+(test {1 2}) (define $loop-pat (lambda [$k $i]
sample/graph-test.egi view
@@ -13,13 +13,13 @@ <node 5 {4} {4}>}) (test (hamilton-cycle g1))-(test {[1 2 3 4 5] [1 5 4 3 2] [2 1 5 4 3] [2 3 4 5 1] [3 2 1 5 4] [3 4 5 1 2] [4 3 2 1 5] [4 5 1 2 3] [5 1 2 3 4] [5 4 3 2 1]})+(test {{1 2 3 4 5} {1 5 4 3 2} {2 1 5 4 3} {2 3 4 5 1} {3 2 1 5 4} {3 4 5 1 2} {4 3 2 1 5} {4 5 1 2 3} {5 1 2 3 4} {5 4 3 2 1}}) (test (hamilton-path g1))-(test {[1 2 3 4 5] [1 5 4 3 2] [2 1 3 4 5] [2 1 5 4 3] [2 3 1 4 5] [2 3 1 5 4] [2 3 4 1 5] [2 3 4 5 1] [3 2 1 4 5] [3 2 1 5 4] [3 4 5 1 2] [4 3 2 1 5] [4 5 1 2 3] [4 5 1 3 2] [5 1 2 3 4] [5 1 4 3 2] [5 4 1 2 3] [5 4 1 3 2] [5 4 3 1 2] [5 4 3 2 1]})+(test {{1 2 3 4 5} {1 5 4 3 2} {2 1 3 4 5} {2 1 5 4 3} {2 3 1 4 5} {2 3 1 5 4} {2 3 4 1 5} {2 3 4 5 1} {3 2 1 4 5} {3 2 1 5 4} {3 4 5 1 2} {4 3 2 1 5} {4 5 1 2 3} {4 5 1 3 2} {5 1 2 3 4} {5 1 4 3 2} {5 4 1 2 3} {5 4 1 3 2} {5 4 3 1 2} {5 4 3 2 1}}) (test (hamilton-cycle g2)) (test {}) (test (hamilton-path g2))-(test {[1 2 3 4 5] [5 4 3 2 1]})+(test {{1 2 3 4 5} {5 4 3 2 1}})