egison 0.2.1.1 → 0.3.0.0
raw patch · 8 files changed
+424/−411 lines, 8 files
Files
- Egison.hs +46/−17
- egison.cabal +2/−2
- etc/elisp/egison-mode.el +1/−1
- etc/lib/collection.egi +205/−0
- etc/lib/number.egi +25/−0
- etc/sample/collection-test.egi +108/−302
- etc/sample/nat-test.egi +0/−89
- etc/sample/number-test.egi +37/−0
Egison.hs view
@@ -8,23 +8,29 @@ import Text.Parsec.Language (haskellDef) import IO hiding (try) +welcomeMsg :: String+welcomeMsg = "Egison, version 0.3.0.0 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n"++byebyeMsg :: String+byebyeMsg = "\nLeaving Egison.\nByebye. See you again! (^^)/\n"+ main :: IO () main = do args <- getArgs case length args of- 0 -> do flushStr "Egison, version 0.2.1.1 : 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!"+ 0 -> do flushStr welcomeMsg+ defsRef <- newIORef []+ runRepl defsRef+ _ -> putStrLn "Program takes only 0 argument!" type Definitions = IORef [(String, Expression)] runRepl :: Definitions -> IO () runRepl defs = do input <- (readPrompt "> ") case input of- Eof -> flushStr "\nLeaving Egison.\nByebye. See you again! (^^)/\n"+ Eof -> flushStr byebyeMsg Input str -> runIOThrows ((readTopExpression str) >>= executeTopExpression defs) >>= flushStr >> runRepl defs -- Input str -> runIOThrows (liftM show (readTopExpression str)) >>= flushStr >> runRepl defs- + readPrompt :: String -> IO Input readPrompt prompt = flushStr prompt >> getExpression @@ -111,8 +117,8 @@ readTopExpression :: String -> IOThrowsError TopExpression readTopExpression exprStr = liftThrows (readOrThrow parseTopExpression exprStr) ---readTopExpressionList :: String -> IOThrowsError [TopExpression]---readTopExpressionList = liftThrows (readOrThrow (sepBy parseTopExpression spaces))+readTopExpressionList :: String -> IOThrowsError [TopExpression]+readTopExpressionList str = liftThrows (readOrThrow (sepBy parseTopExpression spaces) str) readOrThrow :: Parser a -> String -> ThrowsError a readOrThrow parser input = case parse parser "egison" input of@@ -128,6 +134,14 @@ val <- eval (Environment [topFrame]) expr ret <- liftIO (showValue val) return (ret ++ "\n")+executeTopExpression defs (Load filename) = do+ str <- liftIO (readFile filename)+ topExprs <- readTopExpressionList str+ let loop topExprs2 = case topExprs2 of+ [] -> return (filename ++ " loaded\n")+ topExpr:rest -> do executeTopExpression defs topExpr+ loop rest+ in loop topExprs executeTopExpression defs Execute = do topFrame <- makeTopFrame defs mainFn <- eval (Environment [topFrame]) (SymbolExp "main")@@ -147,6 +161,7 @@ data TopExpression = Define String Expression | Test Expression+ | Load String | Execute data Expression = CharacterExp Char@@ -288,7 +303,13 @@ spaces return (Test expr) <|> do try (string "execute")- return Execute) <?> "top expression"+ return Execute+ <|> do try (string "load")+ spaces+ filename <- stringLiteral+ spaces+ return (Load filename)+ ) <?> "top expression" parseExpression :: Parser Expression parseExpression = do ws <- word@@ -921,6 +942,22 @@ patternMatchList newFrames typRefs patRefs tgtRefs patternMatchList _ _ _ _ = throwError (Default "numbers of type, pattern, and target are different") +patternMatchListMap :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame]+patternMatchListMap _ _ _ [] = return []+patternMatchListMap frames typesIValRefs patIValRefs (tgtIValRef:rest) = do+ tgtIValRefs <- tupleToList tgtIValRef+ frames1 <- patternMatchList frames typesIValRefs patIValRefs tgtIValRefs+ frames2 <- patternMatchListMap frames typesIValRefs patIValRefs rest+ return (frames1 ++ frames2)+ +--patternMatchListMapHelper :: [(Frame, IORef IntermidiateValue)] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame]+--patternMatchListMapHelper [] _ _ = return []+--patternMatchListMapHelper ((frame, tgtIValRef):rests) typesIValRefs patIValRefs = do+-- tgtIValRefs <- tupleToList tgtIValRef+-- frames1 <- patternMatchList frames typesIValRefs patIValRefs tgtIValRefs+-- frames2 <- patternMatchListMap frames typesIValRefs patIValRefs rest+-- return (frames1 ++ frames2)+ patternMatch :: [Frame] -> Value -> Value -> IORef IntermidiateValue -> IOThrowsError [Frame] patternMatch [] _ _ _ = return [] patternMatch frames _ (Pattern WildCard) _ = return frames@@ -1003,14 +1040,6 @@ else doDeconstruct deconsInfo frames (InductiveData cons pats) tgtIValRef doDeconstruct _ _ _ _ = throwError (Default "at doDeconstruct : number of types, patterns, and targets are different") -patternMatchListMap :: [Frame] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> [IORef IntermidiateValue] -> IOThrowsError [Frame]-patternMatchListMap _ _ _ [] = return []-patternMatchListMap frames typesIValRefs patIValRefs (tgtIValRef:rest) = do- tgtIValRefs <- tupleToList tgtIValRef- frames1 <- patternMatchList frames typesIValRefs patIValRefs tgtIValRefs- frames2 <- patternMatchListMap frames typesIValRefs patIValRefs rest- return (frames1 ++ frames2)- connectFrames :: [Frame] -> [Frame] -> [Frame] connectFrames [] _ = [] connectFrames (frame:frames) newFrames =
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.2.1.1+Version: 0.3.0.0 -- 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/collection-test.egi sample/io-test.egi elisp/egison-mode.el+Data-files: lib/number.egi lib/collection.egi sample/number-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/elisp/egison-mode.el view
@@ -92,7 +92,7 @@ ((equal "lambda" name) 2) ((equal "let" name) 2) ((equal "match" name) 2)- ((equal "match-map" name) 2)+ ((equal "match-all" name) 2) ((equal "type" name) 2) ((equal "deconstructor" name) 2) ))
+ etc/lib/collection.egi view
@@ -0,0 +1,205 @@+(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 ,x ,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 $add+ (lambda [$a]+ (lambda [$xs $x]+ (match ((member? Int) x xs) Bool+ {[<true> xs]+ [<false> {@xs x}]}))))++(define $union+ (lambda [$a]+ (lambda [$xs $ys]+ (match ys (List a)+ {[<nil> xs]+ [<cons $y $rs> ((union a) ((add 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 $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 $subcollection?+ (lambda [$a]+ (lambda [$xs $ys]+ (match xs (List a)+ {[<nil> <true>]+ [<cons $x $rest>+ (match ((member? a) x ys) Bool+ {[<false> <false>]+ [<true> ((subcollection? a) rest ys)]})]}))))++(define $concat+ (lambda [$xs]+ (match xs (List Something)+ {[<nil> {}]+ [<cons $x $rs> {@x @(concat rs)}]})))++(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 ,x ,xs>]+ <true>]+ [[_ _] <false>]}))]+ })))++(define $Set+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[nil []+ {[{} {[]}]+ [_ {}]}]+ [cons [a (Set a)]+ {[$tgt (let {[$tgt2 ((unique a) tgt)]}+ {@(match-all tgt2 (Multiset a) [<cons $x $xs> [x xs]])+ @(match-all tgt2 (Multiset a) [<cons $x $xs> [x {@xs x}]])})]}]+ [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]]))))]}]+ })]+ [$equal? (lambda [$val $tgt] (and ((subcollection? a) val tgt) ((subcollection? a) tgt val)))]+ })))
+ etc/lib/number.egi view
@@ -0,0 +1,25 @@+(define $Number+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$equal? (lambda [$val $tgt]+ (= val tgt))]}))++(define $Nat+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[o []+ {[0 {[]}]+ [_ {}]+ }]+ [s [Nat]+ {[$tgt (match (compare-number tgt 0) Order+ {[<greater> {(- tgt 1)}]+ [_ {}]})]+ }]+ })]+ [$equal? (lambda [$val $tgt]+ (= val tgt))]+ }))+
etc/sample/collection-test.egi view
@@ -1,58 +1,3 @@-(define $Bool- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[true []- {[<true> {[]}]- [_ {}]}]- [false []- {[<false> {[]}]- [_ {}]}]- })]- [$equal?- (lambda [$val $tgt]- (match [val tgt] [Bool Bool]- {[[<true> <true>] <true>]- [[<false> <false>] <true>]- [[_ _] <false>]}))]- }))--(define $or- (lambda [$b1 $b2]- (match b1 Bool- {[<true> <true>]- [<false> b2]})))--(define $Order- (type- {[$var-match (lambda [$tgt] {tgt})]- [$inductive-match- (deconstructor- {[less []- {[<equal> {[]}]- [_ {}]}]- [equal []- {[<equal> {[]}]- [_ {}]}]- [greater []- {[<greater> {[]}]- [_ {}]}]- })]- [$equal?- (lambda [$val $tgt]- (match [val tgt] [Order Order]- {[[<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})]@@ -81,19 +26,6 @@ [[_ _] <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@@ -115,139 +47,6 @@ <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 ,x ,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 $add- (lambda [$a]- (lambda [$xs $x]- (match ((member? Int) x xs) Bool- {[<true> xs]- [<false> {@xs x}]}))))--(define $union- (lambda [$a]- (lambda [$xs $ys]- (match ys (List a)- {[<nil> xs]- [<cons $y $rs> ((union a) ((add 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 ,x ,xs>]- <true>]- [[_ _] <false>]}))]- })))- (define $poker-hands (lambda [$Cs] (match Cs (Multiset Card)@@ -294,10 +93,10 @@ [<cons <card _ $n> <cons <card _ ,n> <cons <card _ ,n>- !<cons _- !<cons _- !<nil>- >>>>>+ <cons _+ <cons _+ !<nil>+ >>>>> <three-of-kind>] [<cons <card _ $m> <cons <card _ ,m>@@ -309,98 +108,21 @@ <two-pair>] [<cons <card _ $n> <cons <card _ ,n>- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>+ <cons _+ <cons _+ <cons _+ !<nil>+ >>>>> <one-pair>] [<cons _- !<cons _- !<cons _- !<cons _- !<cons _- !<nil>- >>>>>+ <cons _+ <cons _+ <cons _+ <cons _+ !<nil>+ >>>>> <nothing>]}))) -(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)- ((add a) ts2 t)]])- {@ts1 @ts2})]- }]- [join [(Set a) Loop]- {[[$ts1 $ts2] (map (lambda [$ts] [ts [((remove-collection a) ts1 ts)- ((union a) 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>]}))))--(define $not- (lambda [$b]- (match b Bool- {[<true> <false>]- [<false> <true>]})))- (define $ham1 (lambda [$xs $ys] (match [xs ys] [(List Bool) (List Bool)]@@ -410,44 +132,73 @@ [[_ _] <false>]}))) -(test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Int))+(test (match-all {1 2 3} (Multiset Number)+ [<cons $x <cons $y <cons $z <nil>>>> [x y z]]))++(test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Number))+ [<cons <cons $x _>+ <cons <cons $y _>+ <cons <cons $z _>+ <nil>>>>+ [x y z]]))++(test (match-all {{1 2 3} {4 5 1} {6 1 7}} (List (Multiset Number)) [<cons <cons $n _> <cons <cons ,n _> <cons <cons ,n _> <nil>>>> n])) -(test (match (with $loop {1 @loop}) (List Int)+(test (match (with $loop {1 @loop}) (List Number) {[<cons $m <cons $n _>> [m n]] [_ <not-ok>]})) (test (let {[$pat <cons ,1 <nil>>]}- (match {1} (Multiset Int)+ (match {1} (Multiset Number) {[pat <ok>] [_ <not-ok>]}))) -(test (match {1} (Multiset Int)+(test (match {1} (Multiset Number) {[(of {<nil> <cons ,1 <nil>>}) <ok>] [_ <not-ok>]})) (test (let {[$loop <cons ,1 (of {<nil> loop})>]}- (match {1 1 1 1} (Multiset Int)+ (match {1 1 1 1} (Multiset Number) {[loop <ok>] [_ <not-ok>]}))) -(test (match {1 1 1 1} (Multiset Int)+(test (match {1 1 1 1} (Multiset Number) {[(with $loop <cons ,1 (of {<nil> loop})>) <ok>] [_ <not-ok>]})) +(test (match {1 1 1 1} (Multiset Number)+ {[<cons ,1 (with $loop <cons ,1 (of {<nil> loop})>)> <ok>]+ [_ <not-ok>]}))++(test (match {0 1 0 1} (List Number)+ {[(of {<cons ,0 (with $loop (of {<cons ,0 loop> <cons ,1 loop> <nil>}))>+ <cons ,1 (with $loop (of {<cons ,0 loop> <cons ,1 loop> <nil>}))>})+ <ok>]+ [_ <ko>]}))+ (test (match-all {<x> <y> <z>} (List Something) [<nioj $xs $ys> [xs ys]])) -(test (match-all {1 2 3} (List Int)+(test (match-all {1 2 3} (List Number)+ [<join $hs $ts> [hs ts]]))++(test (match-all {1 2 3} (Multiset Number)+ [<join $hs $ts> [hs ts]]))++(test (match-all {1 2 3} (Set Number)+ [<join $hs $ts> [hs ts]]))++(test (match-all {1 2 3} (List Number) [<join $hs <cons $x $ts>> [hs x ts]])) -(test (match-all {1 2 3} (Multiset Int)+(test (match-all {1 2 3} (Multiset Number) [<join $hs <cons $x $ts>> [hs x ts]])) -(test (match-all {1 2 3} (Set Int)+(test (match-all {1 2 3} (Set Number) [<join $hs <cons $x $ts>> [hs x ts]])) (test ((remove-collection Suit) {<club> <heart> <diamond>} {<club> <diamond>}))@@ -477,4 +228,59 @@ <card <club> 5> <card <heart> 1> <card <diamond> 3>}))++(test (match {2 7 7 2 7} (Multiset Number)+ {[<cons $m+ <cons ,m+ <cons ,m+ !<cons $n+ !<cons ,n+ !<nil>>>>>>+ <ok>]+ [ _ <ko>]}))++(test (match {5 2 1 3 4} (Multiset Number)+ {[<cons $n+ <cons ,(- n 1)+ <cons ,(- n 2)+ <cons ,(- n 3)+ <cons ,(- n 4)+ <nil>>>>>>+ <ok>]+ [ _ <ko>]}))++(test (match-all {1 2 3 4 5} (Multiset Number)+ [<cons $n $rest> [n rest]]))++(test (let {[$f (lambda [$x] (+ (g x) 10))]+ [$g (lambda [$x] (+ x 1))]}+ (f 0)))++(define $Stick+ (lambda [$a]+ (type+ {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (deconstructor+ {[nil []+ {[$tgt (match-all tgt (List a) [<nil> []])]+ }]+ [cons [a (List a)]+ {[$tgt {@(match-all tgt (List a) [<cons $x $xs> [x xs]])+ @(match-all (reverse tgt) (List a) [<cons $x $xs> [x xs]])}]+ }]+ [join [(List a) (List a)]+ {[$tgt {@(match-all tgt (List a) [<join $xs $ys> [xs ys]])+ @(match-all (reverse tgt) (List a) [<join $xs $ys> [xs ys]])}]+ }]+ })]+ [$equal? (lambda [$val $tgt]+ (or ((type-ref (List a) equal?) val tgt)+ ((type-ref (List a) equal?) val (reverse tgt))))]+ })))++(test (match-all {1 2 3} (Stick Number) [<cons $x $xs> [x xs]]))+(test (match-all {1 2 3} (Stick Number) [<join $xs $ys> [xs ys]]))+(test (match-all {1 2 3 4} (Stick Number) [<join $xs <cons $w $ys>> [xs w ys]]))+(test (match-all {1 2 3} (Stick Number) [,{3 2 1} <ok>]))
− etc/sample/nat-test.egi
@@ -1,89 +0,0 @@-(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})]- [$inductive-match- (deconstructor- {[o []- {[<o> {[]}] - [_ {}]- }]- [s [Nat]- {[<s $x> {x}]- [_ {}]- }]- })]- [$equal?- (lambda [$val $tgt]- (match [val tgt] [Nat Nat]- {[[<o> <o>] <true>]- [[<s $n1> <s ,n1>] <true>]- [[_ _] <false>]}))]- }))--(define $plus- (lambda [$m $n]- (match m Nat- {[<o> n]- [<s $m1> <s (plus m1 n)>]})))--(define $multiply- (lambda [$m $n]- (match m Nat- {[<o> <o>]- [<s <o>> n]- [<s $m1> (plus n (multiply m1 n))]})))- -(define $fact- (lambda [$n]- (match n Nat- {[<o> <s <o>>]- [<s $n1> (multiply n (fact n1))]})))--(test (fact <s <s <s <o>>>>))--(define $fib- (lambda [$n]- (match n Nat- {[<o> <s <o>>]- [<s <o>> <s <o>>]- [<s <s $n1>> (plus (fib <s n1>) (fib n1))]})))--(test (fib <s <s <s <s <s <s <o>>>>>>>))--(define $monus- (lambda [$m $n]- (match [m n] [Nat Nat]- {[[_ <o>] m]- [[<o> _] <o>]- [[<s $m1> <s $n1>] (monus m1 n1)]})))--(test (monus <s <s <o>>> <s <o>>))--(define $mod- (lambda [$m $n]- (match (monus m n) Nat- {[<o> m]- [$m1 (mod m1 n)]})))--(test (mod <s <s <s <s <o>>>>> <s <s <s <o>>>>))-
+ etc/sample/number-test.egi view
@@ -0,0 +1,37 @@+(define $fib+ (lambda [$n]+ (match n Nat+ {[<o> 1]+ [<s <o>> 1]+ [<s <s $n1>> (+ (fib (+ n1 1)) (fib n1))]})))++(test (fib 10))++(define $fact+ (lambda [$n]+ (match n Nat+ {[<o> 1]+ [<s $n1> (* n (fact n1))]})))++(test (fact 10))++(define $min+ (lambda [$ns]+ (match ns (List Int)+ {[<cons $n <nil>> n]+ [<cons $n $rs>+ (let {[$r (min Rs)]}+ (match (compare-number 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)})]}))))+