egison 2.2.3 → 2.3.0

raw patch · 12 files changed

+296/−334 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• egison.cabal +1/−1
• elisp/egison-mode.el +2/−3
• hs-src/Language/Egison/Core.hs +52/−90
• hs-src/Language/Egison/Macro.hs +3/−2
• hs-src/Language/Egison/Parser.hs +5/−21
• hs-src/Language/Egison/Types.hs +11/−14
• lib/core/base.egi +57/−35
• lib/core/collection.egi +90/−95
• lib/core/number.egi +28/−27
• lib/graph.egi +13/−13
• lib/poker-hands.egi +28/−33
• sample/graph-test.egi +6/−0

@@ -1,5 +1,5 @@ Name:                egison-Version:             2.2.3+Version:             2.3.0 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.

@@ -14,14 +14,13 @@      "\\<let\\>"      "\\<letrec\\>"      "\\<type\\>"-     "\\<type-ref\\>"-     "\\<of\\>"-     "\\<destructor\\>"      "\\<loop\\>"      "\\<match\\>"      "\\<match-all\\>"      "\\<generate-array\\>" +     "\\<Something\\>"+           "\\\."      "\\\,"      "\\\!"

@@ -144,6 +144,7 @@ cEval1 (Closure _ (StringExpr contents)) = return $ Value (String contents) cEval1 (Closure _ (NumberExpr contents)) = return $ Value (Number contents) cEval1 (Closure _ (FloatExpr contents)) = return $ Value (Float contents)+cEval1 (Closure _ SomethingExpr) = return $ Value Something cEval1 (Closure env (VarExpr name numExprs)) = do   numVals <- mapM (eval env) numExprs   nums <- mapM (\nVal -> case nVal of@@ -205,9 +206,10 @@ cEval1 (Closure env (ValuePatExpr expr)) = do   objRef <- liftIO $ makeClosure env expr   return $ Value $ ValuePat objRef-cEval1 (Closure env (PredPatExpr predName argExprs)) = do+cEval1 (Closure env (PredPatExpr predExpr argExprs)) = do+  predObjRef <- liftIO $ makeClosure env predExpr   argObjRefs <- liftIO $ mapM (makeClosure env) argExprs-  return $ Value $ PredPat predName argObjRefs+  return $ Value $ PredPat predObjRef argObjRefs cEval1 (Closure env (CutPatExpr patExpr)) = do   patObjRef <- liftIO $ makeClosure env patExpr   return $ Value $ CutPat patObjRef@@ -241,18 +243,9 @@ cEval1 (Closure env (DoExpr (binding:bindings) body)) = do   newEnv <- extendLet env [binding]   cEval1 $ Closure newEnv $ DoExpr bindings body-cEval1 (Closure env (TypeExpr bindings)) = do-  frameRef <- liftIO $ makeLetRecFrame env bindings-  frame <- liftIO $ readIORef frameRef-  return $ Value $ Type frame-cEval1 (Closure env (TypeRefExpr typExpr name)) = do-  obj <- cEval1 (Closure env typExpr)-  case obj of-    Value (Type frame) -> getVarFromFrame frame (name,[]) >>= cRefEval1-    _ -> throwError $ Default "type-ref: not type"-cEval1 (Closure env (DestructorExpr destructInfoExpr)) = do+cEval1 (Closure env (TypeExpr destructInfoExpr)) = do   destructInfo <- liftIO $ makeDestructInfo destructInfoExpr-  return $ Value $ Destructor destructInfo+  return $ Value $ Type destructInfo  where makeDestructInfo [] = return []        makeDestructInfo ((pppat, typExpr, pmcs):rest) = do          typObjRef <- liftIO $ makeClosure env typExpr@@ -445,79 +438,56 @@                             :states)     Value WildCard -> patternMatch flag ((MState frame atoms):states)     Value (PatVar name nums) -> do-      typ <- cRefEval1 typObjRef-      case typ of-        Value (Type tf) ->-          let mObjRef = Data.Map.lookup ("var-match",[]) tf in-            case mObjRef of-              Nothing -> throwError (Default "no method in type: var-match")-              Just fnObjRef ->-                do ret <- cApply1 fnObjRef tgtObjRef-                   case ret of-                     Intermidiate (ICollection innerObjRefs) -> do-                       objRefs <- innerValRefsToObjRefList innerObjRefs-                       patternMatch flag $ (map (\objRef -> (MState (((name,nums),objRef):frame)-                                                                    (map (\(MAtom (PClosure bf2 pat2) tgt2 typ2) ->-                                                                            (MAtom (PClosure (((name,nums),objRef):bf2) pat2) tgt2 typ2))-                                                                         atoms)))-                                                objRefs) ++ states+      typObj <- cRefEval1 typObjRef+      case typObj of+        Value (Type deconsInfo) -> do+          indRet <- inductiveMatch deconsInfo patObjRef tgtObjRef+          case indRet of+            (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do+              patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))+                                                                            (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))+                                      inTgtObjRefss) ++ states)+        Value Something ->+          patternMatch flag $ (MState (((name, nums), tgtObjRef):frame)+                                      (map (\(MAtom (PClosure bf2 pat2) tgt2 typ2) ->+                                             (MAtom (PClosure (((name, nums), tgtObjRef):bf2) pat2) tgt2 typ2))+                                           atoms)):states         _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"-    Value (ValuePat _) -> do+    Value (ValuePat _) -> do -- same with Inductive Pattern       typObj <- cRefEval1 typObjRef       case typObj of-        Value (Type tf) ->-          let mObjRef = Data.Map.lookup ("inductive-match",[]) tf in-            case mObjRef of-              Nothing -> throwError (Default "no method in type: inductive-match")-              Just fnObjRef ->-                do fnObj <- cRefEval1 fnObjRef-                   case fnObj of-                     Value (Destructor deconInfo) -> do-                       indRet <- inductiveMatch deconInfo patObjRef tgtObjRef-                       case indRet of-                         (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do-                           patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))-                                                                                         (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))-                                                   inTgtObjRefss) ++ states)-                     _ -> throwError $ Default "patternMatch: inductive-match is not destructor"+        Value (Type deconsInfo) -> do+          indRet <- inductiveMatch deconsInfo patObjRef tgtObjRef+          case indRet of+            (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do+              patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))+                                                                            (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))+                                      inTgtObjRefss) ++ states)+        Value Something -> throwError $ Default "patternMatch: Only pattern variable can be pattern matched with Something"         _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"     Value (InductiveData _ _) -> do -- same with ValuePat       typObj <- cRefEval1 typObjRef       case typObj of-        Value (Type tf) ->-          let mObjRef = Data.Map.lookup ("inductive-match",[]) tf in-            case mObjRef of-              Nothing -> throwError (Default "no method in type: inductive-match")-              Just fnObjRef ->-                do fnObj <- cRefEval1 fnObjRef-                   case fnObj of-                     Value (Destructor deconInfo) -> do-                       indRet <- inductiveMatch deconInfo patObjRef tgtObjRef-                       case indRet of-                         (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do-                           patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))-                                                                                         (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))-                                                   inTgtObjRefss) ++ states)-                     _ -> throwError $ Default "patternMatch: inductive-match is not destructor"+        Value (Type deconsInfo) -> do+          indRet <- inductiveMatch deconsInfo patObjRef tgtObjRef+          case indRet of+            (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do+              patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))+                                                                            (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))+                                      inTgtObjRefss) ++ states)+        Value Something -> throwError $ Default "patternMatch: Only pattern variable can be pattern matched with Something"         _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"     Intermidiate (IInductiveData _ _) -> do -- same with ValuePat       typObj <- cRefEval1 typObjRef       case typObj of-        Value (Type tf) ->-          let mObjRef = Data.Map.lookup ("inductive-match",[]) tf in-            case mObjRef of-              Nothing -> throwError (Default "no method in type: inductive-match")-              Just fnObjRef ->-                do fnObj <- cRefEval1 fnObjRef-                   case fnObj of-                     Value (Destructor deconInfo) -> do-                       indRet <- inductiveMatch deconInfo patObjRef tgtObjRef-                       case indRet of-                         (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do-                           patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))-                                                                                         (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))-                                                   inTgtObjRefss) ++ states)-                     _ -> throwError $ Default "patternMatch: inductive-match is not destructor"+        Value (Type deconsInfo) -> do+          indRet <- inductiveMatch deconsInfo patObjRef tgtObjRef+          case indRet of+            (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do+              patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))+                                                                            (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))+                                      inTgtObjRefss) ++ states)+        Value Something -> throwError $ Default "patternMatch: Only pattern variable can be pattern matched with Something"         _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"     Intermidiate (ITuple pats) -> do       patObjRefs <- innerRefsToObjRefList pats@@ -529,21 +499,13 @@       tgtObjRefs <- tupleToObjRefList tgtObjRef       typObjRefs <- tupleToObjRefList typObjRef       patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states-    Value (PredPat predName patObjRefs) -> do-      typObj <- cRefEval1 typObjRef-      case typObj of-        Value (Type tf) ->-          let mObjRef = Data.Map.lookup (predName,[]) tf in-            case mObjRef of-              Nothing -> throwError $ Default $ "no method in type: " ++ predName-              Just fnObjRef -> do-                argsObjRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ map IElement $ patObjRefs ++ [tgtObjRef]-                ret <- cApply1 fnObjRef argsObjRef-                case ret of-                  Value (Bool True) -> patternMatch flag ((MState frame atoms):states)-                  Value (Bool False) -> patternMatch flag states-                  _ -> throwError (Default "patternMatch: return value of pred-pattern is not boolean value")-        _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"+    Value (PredPat predObjRef patObjRefs) -> do+      argsObjRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ map IElement $ patObjRefs ++ [tgtObjRef]+      ret <- cApply1 predObjRef argsObjRef+      case ret of+        Value (Bool True) -> patternMatch flag ((MState frame atoms):states)+        Value (Bool False) -> patternMatch flag states+        _ -> throwError (Default "patternMatch: return value of pred-pattern is not boolean value")     Value (NotPat patObjRef2) -> do       retFrames <- patternMatch MOne [(MState frame [(MAtom (PClosure bf patObjRef2) tgtObjRef typObjRef)])]       case retFrames of

@@ -31,9 +31,10 @@ expandMacro frame (CollectionExpr innerExprs) = do   newInnerExprs <- mapM (expandMacroInnerExpr frame) innerExprs   return $ CollectionExpr newInnerExprs-expandMacro frame (PredPatExpr predName argExprs) = do+expandMacro frame (PredPatExpr predExpr argExprs) = do+  newPredExpr <- expandMacro frame predExpr   newArgExprs <- mapM (expandMacro frame) argExprs-  return $ PredPatExpr predName newArgExprs+  return $ PredPatExpr newPredExpr newArgExprs expandMacro frame (CutPatExpr patExpr) = do   newPatExpr <- expandMacro frame patExpr   return $ CutPatExpr newPatExpr

@@ -269,13 +269,6 @@                                     return (name, expr)))                       whiteSpace) ---parseTypeRefExpr :: Parser EgisonExpr---parseTypeRefExpr = do---  typExpr <- parseExpr---  char '.'---  name <- lexeme identifier---  return $ TypeRefExpr typExpr name- parseVar :: Parser EgisonExpr parseVar = do name <- identifier               nums <- lexeme parseIndexNums@@ -315,9 +308,9 @@   <|> parseNotPat   <|> parseValuePat   <|> parens (do try (char '?' >> many1 space)-                 predName <- lexeme identifier+                 predExpr <- lexeme parseExpr                  argExprs <- sepEndBy parseExpr whiteSpace-                 return (PredPatExpr predName argExprs)+                 return (PredPatExpr predExpr argExprs)           <|> do try (char '|' >> many1 space)                  pats <- sepEndBy parseExpr whiteSpace                  return (OrPatExpr pats)@@ -411,6 +404,8 @@   <|> lexeme parseMacroVarExpr   <|> lexeme parsePatVarOmitExpr   <|> lexeme parseVarOmitExpr+  <|> try (lexeme (do string "Something"+                      return SomethingExpr))   <|> lexeme parseVar   <|> do try (lexeme (string "[|"))          exprs <- sepEndBy parseArrayElementExpr whiteSpace@@ -450,20 +445,9 @@                  bindings <- lexeme parseBindings                  body <- lexeme parseExpr                  return (DoExpr bindings body)-          <|> do try (string "type-ref" >> many1 space)-                 typExpr <- lexeme parseExpr-                 name <- lexeme identifier-                 return (TypeRefExpr typExpr name)-          <|> do try (string "of" >> many1 space)-                 name <- lexeme identifier-                 typExpr <- lexeme parseExpr-                 return (TypeRefExpr typExpr name)           <|> do try (string "type" >> many1 space)-                 bindings <- lexeme parseRecursiveBindings-                 return (TypeExpr bindings)-          <|> do try (string "destructor" >> many1 space)                  deconsInfo <- lexeme parseDestructInfoExpr-                 return (DestructorExpr deconsInfo)+                 return (TypeExpr deconsInfo)           <|> do try (string "match-all" >> many1 space)                  tgtExpr <- lexeme parseExpr                  typExpr <- lexeme parseExpr

@@ -92,7 +92,7 @@   | NotPatExpr EgisonExpr   | AndPatExpr [EgisonExpr]   | OrPatExpr [EgisonExpr]-  | PredPatExpr String [EgisonExpr]+  | PredPatExpr EgisonExpr [EgisonExpr]   | InductiveDataExpr String [EgisonExpr]   | TupleExpr [InnerExpr]   | CollectionExpr [InnerExpr]@@ -105,13 +105,12 @@   | LetExpr Bindings EgisonExpr   | LetRecExpr RecursiveBindings EgisonExpr   | DoExpr Bindings EgisonExpr-  | TypeExpr RecursiveBindings-  | TypeRefExpr EgisonExpr String-  | DestructorExpr DestructInfoExpr+  | TypeExpr DestructInfoExpr   | MatchExpr EgisonExpr EgisonExpr [MatchClause]   | MatchAllExpr EgisonExpr EgisonExpr MatchClause   | GenerateArrayExpr EgisonExpr EgisonExpr   | ApplyExpr EgisonExpr EgisonExpr+  | SomethingExpr  deriving (Show)  data ArrayElementExpr = AElementExpr EgisonExpr@@ -168,7 +167,7 @@   | WildCard   | PatVar String [Integer]   | ValuePat ObjectRef-  | PredPat String [ObjectRef]+  | PredPat ObjectRef [ObjectRef]   | CutPat ObjectRef   | NotPat ObjectRef   | AndPat [ObjectRef]@@ -177,13 +176,13 @@   | Tuple [InnerVal]   | Collection [InnerVal]   | Array Integer [Integer] (Array Integer EgisonVal)-  | Type Frame-  | Destructor DestructInfo+  | Type DestructInfo   | Func Args EgisonExpr Env   | Macro [String] EgisonExpr   | PrimitiveFunc ([EgisonVal] -> ThrowsError EgisonVal)   | IOFunc ([EgisonVal] -> IOThrowsError EgisonVal)   | Port String Handle+  | Something   | EOF  data IntermidiateVal = IInductiveData String [ObjectRef]@@ -352,11 +351,8 @@   "(letrec " ++ showRecursiveBindings bindings ++ " " ++ showExpr body ++ ")" showExpr (DoExpr bindings body) =   "(do " ++ showBindings bindings ++ " " ++ showExpr body ++ ")"-showExpr (TypeExpr bindings) =-  "(type " ++ showRecursiveBindings bindings ++ ")"-showExpr (TypeRefExpr typExpr name) =-  "(type-ref " ++ showExpr typExpr ++ " " ++ name ++ ")"-showExpr (DestructorExpr _) = "(destructor ...)"+showExpr (TypeExpr destructor) =+  "(type " ++ "..." ++ ")" showExpr (MatchExpr tgtExpr typExpr _) =   "(match " ++ showExpr tgtExpr ++ " " ++ showExpr typExpr ++ " ...)" showExpr (MatchAllExpr tgtExpr typExpr _) =@@ -365,7 +361,8 @@   "(generate-array " ++ showExpr fnExpr ++ " " ++ showExpr arrExpr ++ " )" showExpr (ApplyExpr opExpr argExpr) =   "(" ++ showExpr opExpr ++ " " ++ showExpr argExpr ++ ")"-  +showExpr SomethingExpr = "Something"+ ---- |Allow conversion of egisonexpr instances to strings --instance Show EgisonExpr where show = showExpr                       @@ -443,13 +440,13 @@ showVal (Collection innerVals) = "{" ++ showInnerVals innerVals ++ "}" showVal (Array _ ns arr) = showArray ns $ elems arr showVal (Type _) = "#<type>"-showVal (Destructor _) = "#<destructor>" showVal (Func _ _ _) = "(lambda [" ++ "..." ++ "] ...)" showVal (Macro _ _ ) = "(macro [" ++ "..." ++ "] ...)" showVal (PrimitiveFunc _) = "#<primitive>" showVal (IOFunc _) = "#<IO primitive>" showVal (Port _ _) = "#<IO port>" showVal EOF = "#!EOF"+showVal Something = "Something"  -- |Allow conversion of egisonval instances to strings instance Show EgisonVal where show = showVal

@@ -2,21 +2,23 @@ ;; Base.egi ;; -(define $Something (type {[$var-match (lambda [$tgt] {tgt})]}))- (define $Bool   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$inductive-match-      (destructor-        {[<true> []-          {[<true> {[]}]-           [#t {[]}]-           [_ {}]}]-         [<false> []-          {[<false> {[]}]-           [#f {[]}]-           [_ {}]}]})]}))+    {[,$val []+      {[$tgt (if (eq? val tgt)+                 {[]}+                 {})]}]+     [<true> []+      {[<true> {[]}]+       [#t {[]}]+       [_ {}]}]+     [<false> []+      {[<false> {[]}]+       [#f {[]}]+       [_ {}]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))  (define $or   (lambda [$b1 $b2]@@ -38,31 +40,51 @@  (define $Char   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$inductive-match-      (destructor-        {[,$c []-          {[$tgt (if (= tgt c)-                     {[]}-                     {})]}]})]-     [$= eq-c?]}))+    {[,$c []+      {[$tgt (if (eq-c? tgt c)+                 {[]}+                 {})]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))  (define $String   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$= eq-s?]}))+    {[,$s []+      {[$tgt (if (eq-s? tgt s)+                 {[]}+                 {})]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))  (define $Order   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$inductive-match-      (destructor-        {[<less> []-          {[<less> {[]}]-           [_ {}]}]-         [<equal> []-          {[<equal> {[]}]-           [_ {}]}]-         [<greater> []-          {[<greater> {[]}]-           [_ {}]}]})]}))+    {[,$val []+      {[$tgt (if (eq? val tgt)+                 {[]}+                 {})]}]+     [<less> []+      {[<less> {[]}]+       [_ {}]}]+     [<equal> []+      {[<equal> {[]}]+       [_ {}]}]+     [<greater> []+      {[<greater> {[]}]+       [_ {}]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))++(define $match?+  (lambda [$a]+    (lambda [$x $y]+      (match x a+        {[,y #t]+         [_ #f]}))))++(define $=+  (lambda [$a]+    (lambda [$x $y]+      (and (match? x y) (match? y x)))))

@@ -5,55 +5,51 @@ (define $List   (lambda [$a]     (type-      {[$var-match (lambda [$tgt] {tgt})]-       [$inductive-match-        (destructor-          {[,$val []-            {[$tgt (if (= tgt val)-                       {[]}-                       {})]}]-           [<nil> []-            {[{} {[]}]-             [_ {}]}]-           [<cons _ _> [a (List a)]-            {[{$x .$xs} {[x xs]}]-             [_ {}]}]-           [<snoc _ _> [a (List a)]-            {[{.$xs $x} {[x xs]}]-             [_ {}]}]-           [<join ,$pxs _> [(List a)]-            {[$tgt (letrec {[$helper (lambda [$pxs $tgt]-                                       (match [pxs tgt] [(List a) (List a)]-                                         {[[<nil> _] {tgt}]-                                          [[<cons $x $xs> <cons ,x $ys>] (helper xs ys)]-                                          [[_ _] {}]}))]}-                     (helper pxs tgt))]}]-           [<join _ _> [(List a) (List a)]-            {[$tgt (letrec {[$loop-fn-                             (lambda [$ts]-                               (match ts (List a)-                                 {[<nil> {[{} {}]}]-                                  [<cons $x $xs>-                                   {[{} ts]-                                    @(map (lambda [$as $bs] [{x @as} bs])-                                          (loop-fn xs))}]}))]}-                     (loop-fn tgt))]}]-           [<nioj _ _> [(List a) (List a)]-            {[$tgt (letrec {[$loop-fn-                             (lambda [$ts]-                               (match ts (List a)-                                 {[<nil> {[{} {}]}]-                                  [<snoc $x $xs>-                                   {[{} ts]-                                    @(map (lambda [$as $bs] [{@as x} bs])-                                          (loop-fn xs))}]}))]}-                     (loop-fn tgt))]}]})]-       [$= (lambda [$val $tgt]-             (match [val tgt] [(List a) (List a)]-               {[[<nil> <nil>] #t]-                [[<cons $x $xs> <cons ,x ,xs>] #t]-                [[_ _] #f]}))]})))-+      {[,$val []+        {[$tgt (match [val tgt] [(List a) (List a)]+                 {[[<nil> <nil>] {[]}]+                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]+                  [[_ _] {}]})]}]+       [<nil> []+        {[{} {[]}]+         [_ {}]}]+       [<cons _ _> [a (List a)]+        {[{$x .$xs} {[x xs]}]+         [_ {}]}]+       [<snoc _ _> [a (List a)]+        {[{.$xs $x} {[x xs]}]+         [_ {}]}]+       [<join ,$pxs _> [(List a)]+        {[$tgt (letrec {[$helper (lambda [$pxs $tgt]+                                   (match [pxs tgt] [(List a) (List a)]+                                     {[[<nil> _] {tgt}]+                                      [[<cons $x $xs> <cons ,x $ys>] (helper xs ys)]+                                      [[_ _] {}]}))]}+                 (helper pxs tgt))]}]+       [<join _ _> [(List a) (List a)]+        {[$tgt (letrec {[$loop-fn+                         (lambda [$ts]+                           (match ts (List a)+                             {[<nil> {[{} {}]}]+                              [<cons $x $xs>+                               {[{} ts]+                                @(map (lambda [$as $bs] [{x @as} bs])+                                      (loop-fn xs))}]}))]}+                 (loop-fn tgt))]}]+       [<nioj _ _> [(List a) (List a)]+        {[$tgt (letrec {[$loop-fn+                         (lambda [$ts]+                           (match ts (List a)+                             {[<nil> {[{} {}]}]+                              [<snoc $x $xs>+                               {[{} ts]+                                @(map (lambda [$as $bs] [{@as x} bs])+                                      (loop-fn xs))}]}))]}+                 (loop-fn tgt))]}]+       [_ [Something]+        {[$tgt {tgt}]}]+       })))+   (define $map   (lambda [$fn $ls]     (match ls (List Something)@@ -201,53 +197,52 @@ (define $Multiset   (lambda [$a]     (type-      {[$var-match (lambda [$tgt] {tgt})]-       [$inductive-match-        (destructor-          {[,$val []-            {[$tgt (if (= tgt val)-                       {[]}-                       {})]}]-           [<nil> []-            {[{} {[]}]-             [_ {}]}]-           [<cons ,$px _> [(Multiset a)]-            {[$tgt {((remove a) tgt px)}]}]-           [<cons _ _> [a (Multiset a)]-            {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])-                        ((unique a) tgt))]}]-           [<join ,$pxs _> [(Multiset a)]-            {[$tgt {((remove-collection a) tgt pxs)}]}]-           [<join _ _> [(Multiset a) (Multiset a)]-            {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])-                        (subcollections tgt))]}]})]-       [$= (lambda [$val $tgt]-             (match [val tgt] [(Multiset a) (Multiset a)]-               {[[<nil> <nil>] #t]-                [[<cons $x $xs> <cons ,x ,xs>] #t]-                [[_ _] #f]}))]})))+      {[,$val []+        {[$tgt (match [val tgt] [(Multiset a) (Multiset a)]+                 {[[<nil> <nil>] {[]}]+                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]+                  [[_ _] {}]})]}]+       [<nil> []+        {[{} {[]}]+         [_ {}]}]+       [<cons ,$px _> [(Multiset a)]+        {[$tgt (if ((member? a) px tgt)+                   {((remove a) tgt px)}+                   {})]}]+       [<cons _ _> [a (Multiset a)]+        {[$tgt (map (lambda [$t] [t ((remove a) tgt t)])+                    ((unique a) tgt))]}]+       [<join ,$pxs _> [(Multiset a)]+        {[$tgt (if ((subcollection? a) pxs tgt)+                   {((remove-collection a) tgt pxs)}+                   {})]}]+       [<join _ _> [(Multiset a) (Multiset a)]+        {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)])+                    (subcollections tgt))]}]+       [_ [Something]+        {[$tgt {tgt}]}]+       })))  (define $Set   (lambda [$a]     (type-      {[$var-match (lambda [$tgt] {tgt})]-       [$inductive-match-        (destructor-          {[,$val []-            {[$tgt (if (= tgt val)-                       {[]}-                       {})]}]-           [<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]]))))]}]})]-       [$= (lambda [$val $tgt]-             (and ((subcollection? a) val tgt) ((subcollection? a) tgt val)))]})))+      {[,$val []+        {[$tgt (if (and ((subcollection? a) val tgt)+                        ((subcollection? a) tgt val))+                   {[]}+                   {})]}]+       [<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]]))))]}]+       [_ [Something]+        {[$tgt {tgt}]}]+       })))

@@ -1,13 +1,12 @@ (define $Integer   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$inductive-match-      (destructor-        {[,$n []-          {[$tgt (if (= tgt n)-                     {[]}-                     {})]}]})]-     [$= (lambda [$val $tgt] (eq-n? val tgt))]}))+    {[,$n []+      {[$tgt (if (eq-n? tgt n)+                 {[]}+                 {})]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))  (define $compare-integer   (lambda [$m $n]@@ -19,14 +18,13 @@  (define $Double   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$inductive-match-      (destructor-        {[,$d []-          {[$tgt (if (= tgt d)-                     {[]}-                     {})]}]})]-     [$= (lambda [$val $tgt] (eq-f? val tgt))]}))+    {[,$d []+      {[$tgt (if (eq-f? tgt d)+                 {[]}+                 {})]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))  (define $compare-float   (lambda [$d1 $d2]@@ -38,17 +36,20 @@  (define $Nat   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$inductive-match-      (destructor-        {[<o> []-          {[0 {[]}]-           [_ {}]}]-         [<s> Nat-          {[$tgt (match (compare-integer tgt 0) Order-                   {[<greater> {(- tgt 1)}]-                    [_ {}]})]}]})]-     [$= (lambda [$val $tgt] (eq-n? val tgt))]}))+    {[,$n []+      {[$tgt (if (eq-n? tgt n)+                 {[]}+                 {})]}]+     [<o> []+      {[0 {[]}]+       [_ {}]}]+     [<s> Nat+      {[$tgt (match (compare-integer tgt 0) Order+               {[<greater> {(- tgt 1)}]+                [_ {}]})]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))  (define $between   (lambda [$m $n]

@@ -1,20 +1,20 @@+;;;+;;; graph.egi+;;;+ (define $Node Integer)  (define $NodeInfo   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$inductive-match-      (destructor-        {[,$val []-            {[$tgt (if (= tgt val)-                       {[]}-                       {})]}]-         [<node _ _ _> [Node (Multiset Node) (Multiset Node)]-          {[<node $n $in $out> {[n in out]}]}]})]-     [$= (lambda [$val $tgt]-           (match [val tgt] [NodeInfo NodeInfo]-             {[[<node $n $in $out> <node ,n ,in ,out>] #t]-              [[_ _] #f]}))]}))+    {[,$val []+      {[$tgt (match [val tgt] [NodeInfo NodeInfo]+               {[[<node $n $in $out> <node ,n ,in ,out>] {[]}]+                [[_ _] {}]})]}]+     [<node _ _ _> [Node (Multiset Node) (Multiset Node)]+      {[<node $n $in $out> {[n in out]}]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))  (define $Graph (Multiset NodeInfo)) 

@@ -1,25 +1,24 @@ (define $Suit   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$inductive-match-      (destructor-        {[,$suit []-          {[$tgt (if (= tgt suit)-                     {[]}-                     {})]}]-         [<spade> []-          {[<spade> {[]}]-           [_ {}]}]-         [<heart> []-          {[<heart> {[]}]-           [_ {}]}]-         [<club> []-          {[<club> {[]}]-           [_ {}]}]-         [<diamond> []-          {[<diamond> {[]}]-           [_ {}]}]})]-     [$= eq?]}))+    {[,$suit []+      {[$tgt (if (eq? tgt suit)+                 {[]}+                 {})]}]+     [<spade> []+      {[<spade> {[]}]+       [_ {}]}]+     [<heart> []+      {[<heart> {[]}]+       [_ {}]}]+     [<club> []+      {[<club> {[]}]+       [_ {}]}]+     [<diamond> []+      {[<diamond> {[]}]+       [_ {}]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))  (define $Mod   (lambda [$m]@@ -35,19 +34,15 @@  (define $Card   (type-    {[$var-match (lambda [$tgt] {tgt})]-     [$inductive-match-      (destructor-        {[,$card []-            {[$tgt (if (= tgt card)-                       {[]}-                       {})]}]-         [<card _ _> [Suit (Mod 13)]-          {[<card $s $n> {[s n]}]}]})]-     [$= (lambda [$val $tgt]-           (match [val tgt] [Card Card]-             {[[<card $s $n> <card ,s ,n>] #t]-              [[_ _] #f]}))]}))+    {[,$card []+      {[$tgt (match [val tgt] [Card Card]+               {[[<card $s $n> <card ,s ,n>] {[]}]+                [[_ _] {}]})]}]+     [<card _ _> [Suit (Mod 13)]+      {[<card $s $n> {[s n]}]}]+     [_ [Something]+      {[$tgt {tgt}]}]+     }))  (define $poker-hands   (lambda [$Cs]

@@ -4,6 +4,12 @@             <node 4 {1 3 5} {1 3 5}>             <node 5 {1 5} {1 5}>}) +(define $g {<node 1 {2} {2}>+            <node 2 {1 3} {1 3}>+            <node 3 {2 4} {2 4}>+            <node 4 {3 5} {3 5}>+            <node 5 {4} {4}>})+ (test (match-all g Graph         [<cons <node $n1 <cons $n2 _> _>           <cons <node ,n2 <cons $n3 _> _>