egison 0.1.2.3 → 0.1.2.4
raw patch · 6 files changed
+498/−414 lines, 6 files
Files
- Egison.hs +10/−1
- egison.cabal +2/−2
- etc/sample/collection-test.egi +448/−0
- etc/sample/io-test.egi +11/−0
- etc/sample/list-test.egi +0/−404
- etc/sample/nat-test.egi +27/−7
Egison.hs view
@@ -11,7 +11,7 @@ main :: IO () main = do args <- getArgs case length args of- 0 -> do flushStr "Egison, version 0.1.2.3 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"+ 0 -> do flushStr "Egison, version 0.1.2.4 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" defsRef <- newIORef [] runRepl defsRef _ -> putStrLn "Program takes only 0 argument!"@@ -196,6 +196,7 @@ | PrimePatDouble Double | PrimePatVar String | InductivePrimePat String [PrimePat]+ | TuplePrimePat [PrimePat] | EmptyPat | ConsPat PrimePat PrimePat | SnocPat PrimePat PrimePat@@ -437,6 +438,8 @@ spaces ps <- sepEndBy parsePrimePat spaces return (InductivePrimePat c ps))+ <|> brackets (do ps <- sepEndBy parsePrimePat spaces+ return (TuplePrimePat ps)) <|> try (do char '{' spaces char '}'@@ -1055,6 +1058,11 @@ then primitivePatternMatchMap pPats iValRefs else return Nothing _ -> throwError (Default "primitive : not inductive value to primitive inductive pattern")+primitivePatternMatch (TuplePrimePat pPats) iValRef = do+ val <- force iValRef+ case val of+ Tuple iValRefs -> primitivePatternMatchMap pPats iValRefs+ _ -> throwError (Default "primitive : not tuple value to primitive tuple pattern") primitivePatternMatch EmptyPat iValRef = do val <- force iValRef b <- isEmptyCollection val@@ -1385,6 +1393,7 @@ showPrimePat (PrimePatVar name) = "$" ++ name showPrimePat (InductivePrimePat c []) = "<" ++ c ++ ">" showPrimePat (InductivePrimePat c vs) = "<" ++ c ++ " " ++ unwordsList vs ++ ">"+showPrimePat (TuplePrimePat vs) = "[" ++ unwordsList vs ++ "]" showPrimePat EmptyPat = "{}" showPrimePat (ConsPat carPat cdrPat) = "{$" ++ show carPat ++ " .$" ++ show cdrPat ++ "}" showPrimePat (SnocPat rdcPat racPat) = "{.$" ++ show rdcPat ++ " $" ++ show racPat ++ "}"
egison.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.1.2.3+Version: 0.1.2.4 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison@@ -45,7 +45,7 @@ Data-Dir: etc/ -Data-files: sample/nat-test.egi sample/list-test.egi elisp/egison-mode.el+Data-files: sample/nat-test.egi sample/collection-test.egi sample/io-test.egi elisp/egison-mode.el -- Extra files to be distributed with the package, such as examples or -- a README.
+ etc/sample/collection-test.egi view
@@ -0,0 +1,448 @@+(define $Bool+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[true []+ {[<true> {[]}]+ [_ {}]}]+ [false []+ {[<false> {[]}]+ [_ {}]}]+ })]+ [$equal?+ (lambda [$val $tgt]+ (match [val tgt] [Suit Suit]+ {[[<true> <true>] <true>]+ [[<false> <false>] <true>]+ [[_ _] <false>]}))]+ }))++(define $Order+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[less []+ {[<equal> {[]}]+ [_ {}]}]+ [equal []+ {[<equal> {[]}]+ [_ {}]}]+ [greater []+ {[<greater> {[]}]+ [_ {}]}]+ })]+ [$equal?+ (lambda [$val $tgt]+ (match [val tgt] [Suit Suit]+ {[[<less> <less>] <true>]+ [[<equal> <equal>] <true>]+ [[<greater> <greater>] <true>]+ [[_ _] <false>]}))]+ }))++(define $Something+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ }))++(define $Suit+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[spade []+ {[<spade> {[]}]+ [_ {}]}]+ [heart []+ {[<heart> {[]}]+ [_ {}]}]+ [club []+ {[<club> {[]}]+ [_ {}]}]+ [diamond []+ {[<diamond> {[]}]+ [_ {}]}]+ })]+ [$equal?+ (lambda [$val $tgt]+ (match [val tgt] [Suit Suit]+ {[[<spade> <spade>] <true>]+ [[<heart> <heart>] <true>]+ [[<club> <club>] <true>]+ [[<diamond> <diamond>] <true>]+ [[_ _] <false>]}))]+ }))++(define $Nat+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$equal? (lambda [$val $tgt]+ (= val tgt))]}))++(define $Int+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$equal? (lambda [$val $tgt]+ (= val tgt))]+ }))++(define $Mod+ (lambda [$m]+ (type+ {[$var-match (lambda [$tgt] {(mod tgt m)})]+ [$equal? (lambda [$val $tgt]+ (= (mod val m) (mod tgt m)))]})))++(define $Card+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[card [Suit (Mod 13)]+ {[<card $s $n> {[s n]}]}]})]+ [$equal? (lambda [$val $tgt]+ (match [val tgt] [Card Card]+ {[[<card $s $n>+ <card (on [$s] ,s) (on [$n] ,n)>]+ <true>]+ [[_ _] <false>]}))]}))++(define $List+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[nil []+ {[{} {[]}]+ [_ {}]+ }]+ [cons [a (List a)]+ {[{$x .$xs} {[x xs]}]+ [_ {}]+ }]+ [snoc [a (List a)]+ {[{.$xs $x} {[x xs]}]+ [_ {}]+ }]+ [join [(List a) (List a)]+ {[$tgt (let {[$loop+ (lambda [$ts]+ (match ts (List a)+ {[<nil> {[{} {}]}]+ [<cons $x $xs>+ {[{} ts]+ @(map (lambda [$as $bs]+ [{x @as} bs])+ (loop xs))}]}))]}+ (loop tgt))]+ }]+ [nioj [(List a) (List a)]+ {[$tgt (let {[$loop+ (lambda [$ts]+ (match ts (List a)+ {[<nil> {[{} {}]}]+ [<snoc $x $xs>+ {[{} ts]+ @(map (lambda [$as $bs]+ [{@as x} bs])+ (loop xs))}]}))]}+ (loop tgt))]+ }]+ })]+ [$equal? (lambda [$val $tgt]+ (match [val tgt] [(List a) (List a)]+ {[[<nil> <nil>] <true>]+ [[<cons $x $xs>+ <cons (on [$x] ,x) (on [$xs] ,xs)>]+ <true>]+ [[_ _] <false>]}))]+ })))++(define $map+ (lambda [$fn $ls]+ (match ls (List Something)+ {[<nil> {}]+ [<cons $x $xs> {(fn x) @(map fn xs)}]})))++(define $remove+ (lambda [$a]+ (lambda [$xs $x]+ (match xs (List a)+ {[<nil> {}]+ [<cons ,x $rs> rs]+ [<cons $y $rs> {y @((remove a) rs x)}]}))))++(define $remove-all+ (lambda [$a]+ (lambda [$xs $x]+ (match xs (List a)+ {[<nil> {}]+ [<cons ,x $rs> ((remove-all a) rs x)]+ [<cons $y $rs> {y @((remove-all a) rs x)}]}))))++(define $remove-collection+ (lambda [$a]+ (lambda [$xs $ys]+ (match ys (List a)+ {[<nil> xs]+ [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))++(define $subcollections+ (lambda [$xs]+ (match xs (List Something)+ {[<nil> {{}}]+ [<cons $x $rs>+ (let {[$subs (subcollections rs)]}+ {@subs @(map (lambda [$sub] {x @sub})+ subs)})]+ })))++(define $Multiset+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[nil []+ {[{} {[]}]+ [_ {}]+ }]+ [cons [a (Multiset a)]+ {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])+ tgt)]+ }]+ [join [(Multiset a) (Multiset a)]+ {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])+ (subcollections tgt))]+ }]+ })]+ [$equal? (lambda [$val $tgt]+ (match [val tgt] [(Multiset a) (Multiset a)]+ {[[<nil> <nil>] <true>]+ [[<cons $x $xs>+ <cons (on [$x] ,x) (on [$xs] ,xs)>]+ <true>]+ [[_ _] <false>]}))]+ })))++(define $poker-hands+ (lambda [$Cs]+ (match Cs (Multiset Card)+ {[<cons <card $S $n>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 1))>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 2))>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 3))>+ <cons <card (on [$S] ,S) (on [$n] ,(- n 4))>+ !<nil>+ >>>>>+ <straight-flush>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <four-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ !<cons <card _ (on [$n] ,n)>+ !<nil>+ >>>>>+ <full-house>]+ [<cons <card $S _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<cons <card (on [$S] ,S) _>+ !<nil>+ >>>>>+ <flush>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,(- n 1))>+ <cons <card _ (on [$n] ,(- n 2))>+ <cons <card _ (on [$n] ,(- n 3))>+ <cons <card _ (on [$n] ,(- n 4))>+ !<nil>+ >>>>>+ <straight>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <three-of-kind>]+ [<cons <card _ $m>+ <cons <card _ (on [$m] ,m)>+ !<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<nil>+ >>>>>+ <two-pair>]+ [<cons <card _ $n>+ <cons <card _ (on [$n] ,n)>+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <one-pair>]+ [<cons _+ !<cons _+ !<cons _+ !<cons _+ !<cons _+ !<nil>+ >>>>>+ <nothing>]})))++(define $min+ (lambda [$Ns]+ (match Ns (List Int)+ {[<cons $n <nil>> n]+ [<cons $n $Rs>+ (let {[$r (min Rs)]}+ (match ((type-ref Int compare) n r) Order+ {[<less> n]+ [_ r]}))]}))) ++(define $gcd+ (lambda [$ns]+ (let {[$ns2 ((remove-all Int) ns 0)]}+ (match ns2 (Set Int)+ {[<cons $n <nil>> n]+ [<cons ,(min ns2)+ $Rs>+ (gcd {n @(map (lambda [$r] (mod r n))+ Rs)})]}))))++(define $gcd+ (lambda [$Ns]+ (let {[$Ns2 (remove-all Ns 0)]}+ (match Ns2 (Set Int)+ {[<cons $n <nil>> n]+ [<cons ,(min Ns2)+ $Rs>+ (gcd {n @(map (lambda [$r] (mod r n))+ Rs)})]}))))++(define $car+ (lambda [$xs]+ (match xs (List Something)+ {[<cons $x _> x]})))++(define $reverse+ (lambda [$xs]+ (match xs (List Something)+ {[<nil> {}]+ [<cons $x $rs>+ {@(reverse rs) x}]})))++(define $member?+ (lambda [$a]+ (lambda [$x $ys]+ (match ys (List a)+ {[<nil> <false>]+ [<cons ,x $ys> <true>]+ [<cons $y $ys> ((member? a) x ys)]+ }))))++(define $unique+ (lambda [$a]+ (lambda [$xs]+ (let {[$loop (lambda [$xs $ys]+ (match xs (List a)+ {[<nil> ys]+ [<cons $x $rs>+ (match ((member? a) x ys) Bool+ {[<true> (loop rs ys)]+ [<false> (loop rs {@ys x})]+ [_ {}]+ })]}))]}+ (loop xs {})))))++(define $Set+ (lambda [$a]+ (let+ {[$Loop+ (type+ {[$var-match+ (lambda [$ts1 $ts2]+ (map (lambda [$sts2] {@ts1 @sts2})+ (subcollections ts2)))]+ [$inductive-match+ (deconstructor+ {[nil []+ {[[{} _] {[]}]+ [[_ _] {}]+ }]+ [cons [a Loop]+ {[[$ts1 $ts2] (map (lambda [$t] [t [((remove a) ts1 t)+ {@ts2 t}]])+ {@ts1 @ts2})]+ }]+ [join [(Set a) Loop]+ {[[$ts1 $ts2] (map (lambda [$ts] [ts [((remove-collection a) ts1 ts)+ {@ts2 ts}]])+ (subcollections {@ts1 @ts2}))]+ }]+ })]+ [$equal? <undefined>]+ })]}+ (type+ {[$var-match (lambda [$tgt] {$tgt})]+ [$inductive-match+ (lambda [$tgt]+ (let {[$tgt2 ((unique a) tgt)]}+ ((type-ref Loop inductive-match) [tgt2 {}])))]+ [$equal? <undefined>]}))))++++(test (match-map {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))++(test (match-map {<x> <y> <z> <w>} (List Something)+ [<join $hs <cons $x $ts>> [hs x ts]]))++(test (match-map {<x> <y> <z>} (Multiset Something)+ [<join $hs $ts> [hs x ts]]))++(test (match-map {<x> <y> <z>} (Set Something)+ [<join $hs $ts> [hs ts]]))++(test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>}))++(test (subcollections {<x> <y> <z>}))++(test (poker-hands {<card <club> 4>+ <card <club> 2>+ <card <club> 5>+ <card <club> 1>+ <card <club> 3>}))++(test (poker-hands {<card <diamond> 1>+ <card <club> 2>+ <card <club> 1>+ <card <heart> 1>+ <card <diamond> 2>}))++(test (poker-hands {<card <diamond> 4>+ <card <club> 2>+ <card <club> 5>+ <card <heart> 1>+ <card <diamond> 3>}))++(test (poker-hands {<card <diamond> 4>+ <card <club> 10>+ <card <club> 5>+ <card <heart> 1>+ <card <diamond> 3>}))+
+ etc/sample/io-test.egi view
@@ -0,0 +1,11 @@+(define $main+ (lambda [$:]+ (do {[$: (write : "char : ")]+ [[$: $c] (read-char :)]+ [$: (write-char : c)]+ [$: (write-char : '\n')]+ [$: (write : "expr : ")]+ [[$: $e] (read :)]+ [$: (write : e)]+ [$: (write-char : '\n')]}+ :)))
− etc/sample/list-test.egi
@@ -1,404 +0,0 @@-(define $Bool- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[true []- {[<true> {[]}]- [_ {}]}]- [false []- {[<falset> {[]}]- [_ {}]}]- })]- [$equal?- (lambda [$val $tgt]- (match [val tgt] [Suit Suit]- {[[<true> <true>] <true>]- [[<false> <false>] <true>]- [[_ _] <false>]}))]- }))--(define $Something- (type- {[$var-match (lambda [$tgt] {tgt})]- }))--(define $Suit- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[spade []- {[<spade> {[]}]- [_ {}]}]- [heart []- {[<heart> {[]}]- [_ {}]}]- [club []- {[<club> {[]}]- [_ {}]}]- [diamond []- {[<diamond> {[]}]- [_ {}]}]- })]- [$equal?- (lambda [$val $tgt]- (match [val tgt] [Suit Suit]- {[[<spade> <spade>] <true>]- [[<heart> <heart>] <true>]- [[<club> <club>] <true>]- [[<diamond> <diamond>] <true>]- [[_ _] <false>]}))]- }))--(test ((type-ref Suit equal?) <spade> <spade>))--(define $Nat- (type- {[$var-match (lambda [$tgt] {tgt})]- [$equal? (lambda [$val $tgt]- (= val tgt))]}))--(define $Mod- (lambda [$m]- (type- {[$var-match (lambda [$tgt] {(mod tgt m)})]- [$equal? (lambda [$val $tgt]- (= (mod val m) (mod tgt m)))]})))--(test (match 10 Nat- {[,(- 12 2) <ok>]- [_ <not-ok>]}))--(test (match 10 (Mod 13)- {[,(- 12 2) <ok>]- [_ <not-ok>]}))--(define $Card- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[card [Suit (Mod 13)]- {[<card $s $n> {[s n]}]}]})]- [$equal? (lambda [$val $tgt]- (match [val tgt] [Card Card]- {[[<card $s $n>- <card (on [$s] ,s) (on [$n] ,n)>]- <true>]- [[_ _] <false>]}))]}))--(test (match <card <diamond> 12> Card- {[<card <club> ,12> <not-ok>]- [<card <diamond> ,10> <not-ok>]- [,<card <diamond> 12> <ok2>]- [<card _ ,12> <ok>]- [_ <not-ok>]}))--(define $List- (lambda [$a]- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[nil []- {[{} {[]}]- [_ {}]- }]- [cons [a (List a)]- {[{$x .$xs} {[x xs]}]- [_ {}]- }]- [snoc [a (List a)]- {[{.$xs $x} {[x xs]}]- [_ {}]- }]- [join [(List a) (List a)]- {[$tgt (let {[$loop- (lambda [$ts]- (match ts (List a)- {[<nil> {[{} {}]}]- [<cons $x $xs>- {[{} ts]- @(map (lambda [$as $bs]- [{x @as} bs])- (loop xs))}]}))]}- (loop tgt))]- }]- [nioj [(List a) (List a)]- {[$tgt (let {[$loop- (lambda [$ts]- (match ts (List a)- {[<nil> {[{} {}]}]- [<snoc $x $xs>- {[{} ts]- @(map (lambda [$as $bs]- [{@as x} bs])- (loop xs))}]}))]}- (loop tgt))]- }]- })]- [$equal? (lambda [$val $tgt]- (match [val tgt] [(List a) (List a)]- {[[<nil> <nil>] <true>]- [[<cons $x $xs>- <cons (on [$x] ,x) (on [$xs] ,xs)>]- <true>]- [[_ _] <false>]}))]- })))--(test (match-map {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]]))--(define $map- (lambda [$fn $ls]- (match ls (List Something)- {[<nil> {}]- [<cons $x $xs> {(fn x) @(map fn xs)}]})))--(test (match-map {<x> <y> <z> <w>} (List Something)- [<join $hs <cons $x $ts>> [hs x ts]]))--(define $remove- (lambda [$a]- (lambda [$xs $x]- (match xs (List a)- {[<nil> {}]- [<cons ,x $rs> rs]- [<cons $y $rs> {y @((remove a) rs x)}]}))))--(test ((remove Suit) {<club> <diamond>} <diamond>))--(test ((remove Nat) {1 2} 1))--(define $remove-collection- (lambda [$a]- (lambda [$xs $ys]- (match ys (List a)- {[<nil> xs]- [<cons $y $rs> ((remove-collection a) ((remove a) xs y) rs)]}))))--(test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>}))--(define $subcollection- (lambda [$xs]- (match xs (List Something)- {[<nil> {{}}]- [<cons $x $rs>- (let {[$subs (subcollection rs)]}- {@subs @(map (lambda [$sub] {x @sub})- subs)})]- })))--(test (subcollection {<x> <y> <z>}))--(define $Multiset- (lambda [$a]- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[nil []- {[{} {[]}]- [_ {}]- }]- [cons [a (Multiset a)]- {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])- tgt)]- }]- [join [(Multiset a) (Multiset a)]- {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])- (subcollections tgt))]- }]- })]- [$equal? (lambda [$val $tgt]- (match [val tgt] [(Multiset a) (Multiset a)]- {[[<nil> <nil>] <true>]- [[<cons $x $xs>- <cons (on [$x] ,x) (on [$xs] ,xs)>]- <true>]- [[_ _] <false>]}))]- })))---(define $one-pair- (lambda [$ns]- (match ns (Multiset Suit)- {[<cons $n <cons (on [$n] ,n) _>> <ok>]- [_ <nothing>]})))- -(test (one-pair {<club> <spade> <club>}))--(define $list-nat- (lambda [$ns]- (match ns (List Nat)- {[<cons $n <cons (on [$n] ,n) _>> n]- [_ <not-ok>]})))--(test (list-nat {1 1 3}))--(define $multiset-nat- (lambda [$ns]- (match ns (Multiset Nat)- {[<cons $n <cons (on [$n] ,n) _>> n]- [_ <not-ok>]})))--(test (multiset-nat {1 1 3}))--(define $full-house- (lambda [$ns]- (match ns (Multiset Nat)- {[<cons $m- <cons (on [$m] ,m)- <cons (on [$m] ,m)- !<cons $n- !<cons (on [$n] ,n)- !<nil>- >>>>>- <full-house>]- [_ <nothing>]- })))--(test (full-house {1 1 0 0 1}))--(define $poker-hands- (lambda [$Cs]- (match Cs (Multiset Card)- {[<cons <card $S $n>- <cons <card (on [$S] ,S) (on [$n] ,(- n 1))>- <cons <card (on [$S] ,S) (on [$n] ,(- n 2))>- <cons <card (on [$S] ,S) (on [$n] ,(- n 3))>- <cons <card (on [$S] ,S) (on [$n] ,(- n 4))>- !<nil>- >>>>>- <straight-flush>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>- !<cons <card _ (on [$n] ,n)>- !<cons _- !<nil>- >>>>>- <four-of-kind>]- [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>- <cons <card _ (on [$m] ,m)>- !<cons <card _ $n>- !<cons <card _ (on [$n] ,n)>- !<nil>- >>>>>- <full-house>]- [<cons <card $S _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<cons <card (on [$S] ,S) _>- !<nil>- >>>>>- <flush>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,(- n 1))>- <cons <card _ (on [$n] ,(- n 2))>- <cons <card _ (on [$n] ,(- n 3))>- <cons <card _ (on [$n] ,(- n 4))>- !<nil>- >>>>>- <straight>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- <cons <card _ (on [$n] ,n)>- !<cons _- !<cons _- !<nil>- >>>>>- <three-of-kind>]- [<cons <card _ $m>- <cons <card _ (on [$m] ,m)>- !<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons _- !<nil>- >>>>>- <two-pair>]- [<cons <card _ $n>- <cons <card _ (on [$n] ,n)>- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>- <one-pair>]- [<cons _- !<cons _- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>- <nothing>]})))--(test (poker-hands {<card <club> 4>- <card <club> 2>- <card <club> 5>- <card <club> 1>- <card <club> 3>}))--(test (poker-hands {<card <diamond> 1>- <card <club> 2>- <card <club> 1>- <card <heart> 1>- <card <diamond> 2>}))--(test (poker-hands {<card <diamond> 4>- <card <club> 2>- <card <club> 5>- <card <heart> 1>- <card <diamond> 3>}))--(test (poker-hands {<card <diamond> 4>- <card <club> 10>- <card <club> 5>- <card <heart> 1>- <card <diamond> 3>}))--(define $car- (lambda [$as]- (match as (List Something)- {[<cons $a _> a]})))--(define $reverse- (lambda [$as]- (match as (List Something)- {[<nil> {}]- [<cons $a $rs>- {@(reverse rs) a}]})))---(define $min- (lambda [$Ns]- (match Ns (List Int)- {[<cons $n <nil>> n]- [<cons $n $Rs>- (let {[$r (min Rs)]}- (match (compare n r) Order- {[<less> n]- [_ r]}))]}))) --(define $gcd- (lambda [$Ns]- (let {[$Ns2 (remove-all Ns 0)]}- (match ns2 (Multiset Int)- {[<cons $n <nil>> n]- [<cons ,(min Ns2)- $Rs>- (gcd {n @(map (lambda [$r] (mod r n))- Rs)})]}))))--(define $gcd- (lambda [$Ns]- (let {[$Ns2 (remove-all Ns 0)]}- (match Ns2 (Set Int)- {[<cons $n <nil>> n]- [<cons ,(min Ns2)- $Rs>- (gcd {n @(map (lambda [$r] (mod r n))- Rs)})]}))))
etc/sample/nat-test.egi view
@@ -1,3 +1,23 @@+(define $Bool+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[true []+ {[<true> {[]}]+ [_ {}]}]+ [false []+ {[<false> {[]}]+ [_ {}]}]+ })]+ [$equal?+ (lambda [$val $tgt]+ (match [val tgt] [Suit Suit]+ {[[<true> <true>] <true>]+ [[<false> <false>] <true>]+ [[_ _] <false>]}))]+ }))+ (define $Nat (type {[$var-match (lambda [$tgt] {tgt})]@@ -16,28 +36,28 @@ (lambda [$val $tgt] (match [val tgt] [Nat Nat] {[[<o> <o>] <true>]- [[<s $n1> <s $n2>] (= n1 n2)]+ [[<s $n1> <s (on [$n1] ,n1)>] <true>] [[_ _] <false>]}))] })) -(define $++(define $plus (lambda [$m $n] (match m Nat {[<o> n]- [<s $m1> <s (+ m1 n)>]})))+ [<s $m1> <s (plus m1 n)>]}))) -(define $*+(define $multiply (lambda [$m $n] (match m Nat {[<o> <o>] [<s <o>> n]- [<s $m1> (+ n (* m1 n))]})))+ [<s $m1> (plus n (multiply m1 n))]}))) (define $fact (lambda [$n] (match n Nat {[<o> <s <o>>]- [<s $n1> (* n (fact n1))]})))+ [<s $n1> (multiply n (fact n1))]}))) (test (fact <s <s <s <o>>>>)) @@ -46,7 +66,7 @@ (match n Nat {[<o> <s <o>>] [<s <o>> <s <o>>]- [<s <s $n1>> (+ (fib <s n1>) (fib n1))]})))+ [<s <s $n1>> (plus (fib <s n1>) (fib n1))]}))) (test (fib <s <s <s <s <s <s <o>>>>>>>))