diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -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. diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -14,14 +14,13 @@ "\\" "\\" "\\" - "\\" - "\\" - "\\" "\\" "\\" "\\" "\\" + "\\" + "\\\." "\\\," "\\\!" diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -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 diff --git a/hs-src/Language/Egison/Macro.hs b/hs-src/Language/Egison/Macro.hs --- a/hs-src/Language/Egison/Macro.hs +++ b/hs-src/Language/Egison/Macro.hs @@ -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 diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -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 diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -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 _) = "#" -showVal (Destructor _) = "#" showVal (Func _ _ _) = "(lambda [" ++ "..." ++ "] ...)" showVal (Macro _ _ ) = "(macro [" ++ "..." ++ "] ...)" showVal (PrimitiveFunc _) = "#" showVal (IOFunc _) = "#" showVal (Port _ _) = "#" showVal EOF = "#!EOF" +showVal Something = "Something" -- |Allow conversion of egisonval instances to strings instance Show EgisonVal where show = showVal diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -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 - {[ [] - {[ {[]}] - [#t {[]}] - [_ {}]}] - [ [] - {[ {[]}] - [#f {[]}] - [_ {}]}]})]})) + {[,$val [] + {[$tgt (if (eq? val tgt) + {[]} + {})]}] + [ [] + {[ {[]}] + [#t {[]}] + [_ {}]}] + [ [] + {[ {[]}] + [#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 - {[ [] - {[ {[]}] - [_ {}]}] - [ [] - {[ {[]}] - [_ {}]}] - [ [] - {[ {[]}] - [_ {}]}]})]})) + {[,$val [] + {[$tgt (if (eq? val tgt) + {[]} + {})]}] + [ [] + {[ {[]}] + [_ {}]}] + [ [] + {[ {[]}] + [_ {}]}] + [ [] + {[ {[]}] + [_ {}]}] + [_ [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))))) diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -5,55 +5,51 @@ (define $List (lambda [$a] (type - {[$var-match (lambda [$tgt] {tgt})] - [$inductive-match - (destructor - {[,$val [] - {[$tgt (if (= tgt val) - {[]} - {})]}] - [ [] - {[{} {[]}] - [_ {}]}] - [ [a (List a)] - {[{$x .$xs} {[x xs]}] - [_ {}]}] - [ [a (List a)] - {[{.$xs $x} {[x xs]}] - [_ {}]}] - [ [(List a)] - {[$tgt (letrec {[$helper (lambda [$pxs $tgt] - (match [pxs tgt] [(List a) (List a)] - {[[ _] {tgt}] - [[ ] (helper xs ys)] - [[_ _] {}]}))]} - (helper pxs tgt))]}] - [ [(List a) (List a)] - {[$tgt (letrec {[$loop-fn - (lambda [$ts] - (match ts (List a) - {[ {[{} {}]}] - [ - {[{} ts] - @(map (lambda [$as $bs] [{x @as} bs]) - (loop-fn xs))}]}))]} - (loop-fn tgt))]}] - [ [(List a) (List a)] - {[$tgt (letrec {[$loop-fn - (lambda [$ts] - (match ts (List a) - {[ {[{} {}]}] - [ - {[{} ts] - @(map (lambda [$as $bs] [{@as x} bs]) - (loop-fn xs))}]}))]} - (loop-fn tgt))]}]})] - [$= (lambda [$val $tgt] - (match [val tgt] [(List a) (List a)] - {[[ ] #t] - [[ ] #t] - [[_ _] #f]}))]}))) - + {[,$val [] + {[$tgt (match [val tgt] [(List a) (List a)] + {[[ ] {[]}] + [[ ] {[]}] + [[_ _] {}]})]}] + [ [] + {[{} {[]}] + [_ {}]}] + [ [a (List a)] + {[{$x .$xs} {[x xs]}] + [_ {}]}] + [ [a (List a)] + {[{.$xs $x} {[x xs]}] + [_ {}]}] + [ [(List a)] + {[$tgt (letrec {[$helper (lambda [$pxs $tgt] + (match [pxs tgt] [(List a) (List a)] + {[[ _] {tgt}] + [[ ] (helper xs ys)] + [[_ _] {}]}))]} + (helper pxs tgt))]}] + [ [(List a) (List a)] + {[$tgt (letrec {[$loop-fn + (lambda [$ts] + (match ts (List a) + {[ {[{} {}]}] + [ + {[{} ts] + @(map (lambda [$as $bs] [{x @as} bs]) + (loop-fn xs))}]}))]} + (loop-fn tgt))]}] + [ [(List a) (List a)] + {[$tgt (letrec {[$loop-fn + (lambda [$ts] + (match ts (List a) + {[ {[{} {}]}] + [ + {[{} 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) - {[]} - {})]}] - [ [] - {[{} {[]}] - [_ {}]}] - [ [(Multiset a)] - {[$tgt {((remove a) tgt px)}]}] - [ [a (Multiset a)] - {[$tgt (map (lambda [$t] [t ((remove a) tgt t)]) - ((unique a) tgt))]}] - [ [(Multiset a)] - {[$tgt {((remove-collection a) tgt pxs)}]}] - [ [(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)] - {[[ ] #t] - [[ ] #t] - [[_ _] #f]}))]}))) + {[,$val [] + {[$tgt (match [val tgt] [(Multiset a) (Multiset a)] + {[[ ] {[]}] + [[ ] {[]}] + [[_ _] {}]})]}] + [ [] + {[{} {[]}] + [_ {}]}] + [ [(Multiset a)] + {[$tgt (if ((member? a) px tgt) + {((remove a) tgt px)} + {})]}] + [ [a (Multiset a)] + {[$tgt (map (lambda [$t] [t ((remove a) tgt t)]) + ((unique a) tgt))]}] + [ [(Multiset a)] + {[$tgt (if ((subcollection? a) pxs tgt) + {((remove-collection a) tgt pxs)} + {})]}] + [ [(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) - {[]} - {})]}] - [ [] - {[{} {[]}] - [_ {}]}] - [ [a (Set a)] - {[$tgt (let {[$tgt2 ((unique a) tgt)]} - {@(match-all tgt2 (Multiset a) [ [x xs]]) - @(match-all tgt2 (Multiset a) [ [x {@xs x}]])})]}] - [ [(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) [ [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)) + {[]} + {})]}] + [ [] + {[{} {[]}] + [_ {}]}] + [ [a (Set a)] + {[$tgt (let {[$tgt2 ((unique a) tgt)]} + {@(match-all tgt2 (Multiset a) [ [x xs]]) + @(match-all tgt2 (Multiset a) [ [x {@xs x}]])})]}] + [ [(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) [ [xs ys]]))))]}] + [_ [Something] + {[$tgt {tgt}]}] + }))) diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -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 - {[ [] - {[0 {[]}] - [_ {}]}] - [ Nat - {[$tgt (match (compare-integer tgt 0) Order - {[ {(- tgt 1)}] - [_ {}]})]}]})] - [$= (lambda [$val $tgt] (eq-n? val tgt))]})) + {[,$n [] + {[$tgt (if (eq-n? tgt n) + {[]} + {})]}] + [ [] + {[0 {[]}] + [_ {}]}] + [ Nat + {[$tgt (match (compare-integer tgt 0) Order + {[ {(- tgt 1)}] + [_ {}]})]}] + [_ [Something] + {[$tgt {tgt}]}] + })) (define $between (lambda [$m $n] diff --git a/lib/graph.egi b/lib/graph.egi --- a/lib/graph.egi +++ b/lib/graph.egi @@ -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 (Multiset Node) (Multiset Node)] - {[ {[n in out]}]}]})] - [$= (lambda [$val $tgt] - (match [val tgt] [NodeInfo NodeInfo] - {[[ ] #t] - [[_ _] #f]}))]})) + {[,$val [] + {[$tgt (match [val tgt] [NodeInfo NodeInfo] + {[[ ] {[]}] + [[_ _] {}]})]}] + [ [Node (Multiset Node) (Multiset Node)] + {[ {[n in out]}]}] + [_ [Something] + {[$tgt {tgt}]}] + })) (define $Graph (Multiset NodeInfo)) diff --git a/lib/poker-hands.egi b/lib/poker-hands.egi --- a/lib/poker-hands.egi +++ b/lib/poker-hands.egi @@ -1,25 +1,24 @@ (define $Suit (type - {[$var-match (lambda [$tgt] {tgt})] - [$inductive-match - (destructor - {[,$suit [] - {[$tgt (if (= tgt suit) - {[]} - {})]}] - [ [] - {[ {[]}] - [_ {}]}] - [ [] - {[ {[]}] - [_ {}]}] - [ [] - {[ {[]}] - [_ {}]}] - [ [] - {[ {[]}] - [_ {}]}]})] - [$= eq?]})) + {[,$suit [] + {[$tgt (if (eq? tgt suit) + {[]} + {})]}] + [ [] + {[ {[]}] + [_ {}]}] + [ [] + {[ {[]}] + [_ {}]}] + [ [] + {[ {[]}] + [_ {}]}] + [ [] + {[ {[]}] + [_ {}]}] + [_ [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) - {[]} - {})]}] - [ [Suit (Mod 13)] - {[ {[s n]}]}]})] - [$= (lambda [$val $tgt] - (match [val tgt] [Card Card] - {[[ ] #t] - [[_ _] #f]}))]})) + {[,$card [] + {[$tgt (match [val tgt] [Card Card] + {[[ ] {[]}] + [[_ _] {}]})]}] + [ [Suit (Mod 13)] + {[ {[s n]}]}] + [_ [Something] + {[$tgt {tgt}]}] + })) (define $poker-hands (lambda [$Cs] diff --git a/sample/graph-test.egi b/sample/graph-test.egi --- a/sample/graph-test.egi +++ b/sample/graph-test.egi @@ -4,6 +4,12 @@ }) +(define $g { + + + + }) + (test (match-all g Graph [ _> _>