egison 2.1.16 → 2.2.0
raw patch · 9 files changed
+200/−82 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.Egison.Core: primitivePatPatternMatch :: PrimitivePatPattern -> ObjectRef -> IOThrowsError (Maybe ([ObjectRef], FrameList))
+ Language.Egison.Core: primitivePatPatternMatchList :: [PrimitivePatPattern] -> [ObjectRef] -> IOThrowsError (Maybe ([ObjectRef], FrameList))
+ Language.Egison.Parser: parsePrimitivePatPattern :: Parser PrimitivePatPattern
+ Language.Egison.Types: PPInductivePat :: String -> [PrimitivePatPattern] -> PrimitivePatPattern
+ Language.Egison.Types: PPValuePat :: String -> PrimitivePatPattern
+ Language.Egison.Types: PPWildCard :: PrimitivePatPattern
+ Language.Egison.Types: ValuePat :: ObjectRef -> EgisonVal
+ Language.Egison.Types: ValuePatExpr :: EgisonExpr -> EgisonExpr
+ Language.Egison.Types: data PrimitivePatPattern
+ Language.Egison.Types: instance Show PrimitivePatPattern
- Language.Egison.Core: inductiveMatch :: DestructInfo -> String -> ObjectRef -> IOThrowsError (ObjectRef, ObjectRef)
+ Language.Egison.Core: inductiveMatch :: DestructInfo -> ObjectRef -> ObjectRef -> IOThrowsError ([ObjectRef], [ObjectRef], [[ObjectRef]])
- Language.Egison.Parser: parseDestructClause :: Parser (String, EgisonExpr, [(PrimitivePattern, EgisonExpr)])
+ Language.Egison.Parser: parseDestructClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitivePattern, EgisonExpr)])
- Language.Egison.Types: type DestructInfo = [(String, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])]
+ Language.Egison.Types: type DestructInfo = [(PrimitivePatPattern, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])]
- Language.Egison.Types: type DestructInfoExpr = [(String, EgisonExpr, [(PrimitivePattern, EgisonExpr)])]
+ Language.Egison.Types: type DestructInfoExpr = [(PrimitivePatPattern, EgisonExpr, [(PrimitivePattern, EgisonExpr)])]
Files
- egison.cabal +1/−1
- hs-src/Language/Egison/Core.hs +92/−36
- hs-src/Language/Egison/Parser.hs +16/−4
- hs-src/Language/Egison/Types.hs +12/−2
- lib/core/base.egi +7/−20
- lib/core/collection.egi +34/−11
- lib/core/number.egi +14/−2
- lib/graph.egi +5/−1
- lib/poker-hands.egi +19/−5
egison.cabal view
@@ -1,5 +1,5 @@ Name: egison-Version: 2.1.16+Version: 2.2.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.
hs-src/Language/Egison/Core.hs view
@@ -177,6 +177,9 @@ _ -> throwError $ Default "cEval1: cannot reach here!") numVals return $ Value $ PatVar name nums+cEval1 (Closure env (ValuePatExpr expr)) = do+ objRef <- liftIO $ makeClosure env expr+ return $ Value $ ValuePat objRef cEval1 (Closure env (PredPatExpr predName argExprs)) = do argObjRefs <- liftIO $ mapM (makeClosure env) argExprs return $ Value $ PredPat predName argObjRefs@@ -226,11 +229,11 @@ destructInfo <- liftIO $ makeDestructInfo destructInfoExpr return $ Value $ Destructor destructInfo where makeDestructInfo [] = return []- makeDestructInfo ((cons, typExpr, pmcs):rest) = do+ makeDestructInfo ((pppat, typExpr, pmcs):rest) = do typObjRef <- liftIO $ makeClosure env typExpr let epmcs = map (\(ppat, body) -> (env, ppat, body)) pmcs retRest <- makeDestructInfo rest- return ((cons, typObjRef, epmcs):retRest)+ return ((pppat, typObjRef, epmcs):retRest) cEval1 (Closure env (MatchAllExpr tgtExpr typExpr (patExpr, body))) = do patObjRef <- liftIO $ makeClosure env patExpr tgtObjRef <- liftIO $ makeClosure env tgtExpr@@ -410,7 +413,7 @@ atoms))) objRefs) ++ states _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"- Intermidiate (IInductiveData con patObjRefs) -> do+ Value (ValuePat _) -> do typObj <- cRefEval1 typObjRef case typObj of Value (Type tf) ->@@ -421,18 +424,15 @@ do fnObj <- cRefEval1 fnObjRef case fnObj of Value (Destructor deconInfo) -> do- indRet <- inductiveMatch deconInfo con tgtObjRef+ indRet <- inductiveMatch deconInfo patObjRef tgtObjRef case indRet of- (nTypObjRef, nTgtsObjRef) -> do- inTypObjRefs <- tupleToObjRefList nTypObjRef- inTgtsRefs <- collectionToObjRefList nTgtsObjRef- inTgtObjRefss <- mapM tupleToObjRefList inTgtsRefs+ (inTypObjRefs, inPatObjRefs, inTgtObjRefss) -> do patternMatch flag ((map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef))- (zip3 patObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))+ (zip3 inPatObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms))) inTgtObjRefss) ++ states)+ _ -> throwError $ Default "patternMatch: inductive-match is not destructor" _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"- Value (InductiveData con pats) -> do- patObjRefs <- liftIO $ mapM (newIORef . Value) pats+ Value (InductiveData _ _) -> do -- same with ValuePat typObj <- cRefEval1 typObjRef case typObj of Value (Type tf) ->@@ -443,16 +443,33 @@ do fnObj <- cRefEval1 fnObjRef case fnObj of Value (Destructor deconInfo) -> do- indRet <- inductiveMatch deconInfo con tgtObjRef+ indRet <- inductiveMatch deconInfo patObjRef tgtObjRef case indRet of- (nTypObjRef, nTgtsObjRef) -> do- inTypObjRefs <- tupleToObjRefList nTypObjRef- inTgtsRefs <- collectionToObjRefList nTgtsObjRef- inTgtObjRefss <- mapM tupleToObjRefList inTgtsRefs- patternMatch flag $ (map (\inTgtObjRefs -> (MState frame ((map (\(pat,inTgtObjRef,inTypObjRef) -> MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)- (zip3 patObjRefs inTgtObjRefs inTypObjRefs)) ++ atoms)))- inTgtObjRefss) ++ states+ (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" _ -> 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"+ _ -> throwError $ Default "patternMatch: second argument of match expressions must be type" Intermidiate (ITuple pats) -> do patObjRefs <- innerRefsToObjRefList pats tgtObjRefs <- tupleToObjRefList tgtObjRef@@ -498,25 +515,64 @@ MOne -> return retFrames _ -> throwError $ Default $ "invalid pattern: " ++ show patObj -inductiveMatch :: DestructInfo -> String -> ObjectRef -> IOThrowsError (ObjectRef,ObjectRef)-inductiveMatch [] _ _ = throwError (Default "inductiveMatch: not matched any clauses")-inductiveMatch ((con,_,[]):rest) pcon tgtObjRefRef =- if (con == pcon)- then throwError (Default "inductiveMatch: not matched any clauses")- else inductiveMatch rest pcon tgtObjRefRef-inductiveMatch ((con,typObjRef,((env,ppat,expr):cls)):rest) pcon tgtObjRefRef = do- if (con == pcon)- then do mPpmRet <- primitivePatternMatch ppat tgtObjRefRef- - case mPpmRet of- Nothing -> inductiveMatch ((con,typObjRef,cls):rest) pcon tgtObjRefRef- Just ppmRet -> do- newEnv <- liftIO $ extendEnv env ppmRet- ret <- liftIO $ makeClosure newEnv expr- return (typObjRef,ret)- else inductiveMatch rest pcon tgtObjRefRef+inductiveMatch :: DestructInfo -> ObjectRef -> ObjectRef -> IOThrowsError ([ObjectRef], [ObjectRef], [[ObjectRef]])+inductiveMatch [] _ _ = throwError $ Default "inductiveMatch: not matched any primitive pattern clauses"+inductiveMatch ((pppat, typObjRef, pclss):rest) patObjRef tgtObjRef = do+ mRet <- primitivePatPatternMatch pppat patObjRef+ case mRet of+ Nothing -> inductiveMatch rest patObjRef tgtObjRef+ Just (patObjRefs, frame) -> do+ mPpmRet <- helper pclss+ case mPpmRet of+ Nothing -> throwError $ Default "inductiveMatch: not matched any primitive clauses"+ Just tgtObjRefs -> do+ typObjRefs <- tupleToObjRefList typObjRef+ return (typObjRefs, patObjRefs, tgtObjRefs)+ where helper [] = return Nothing+ helper ((env, ppat, expr):pclss2) = do+ mPpmRet <- primitivePatternMatch ppat tgtObjRef+ case mPpmRet of+ Nothing -> helper pclss2+ Just ppmRet -> do+ newEnv <- liftIO $ extendEnv env (ppmRet ++ frame)+ retObjRef <- liftIO $ makeClosure newEnv expr+ tgtObjRefs <- collectionToObjRefList retObjRef+ tgtObjRefss <- mapM tupleToObjRefList tgtObjRefs+ return $ Just tgtObjRefss +primitivePatPatternMatch :: PrimitivePatPattern -> ObjectRef -> IOThrowsError (Maybe ([ObjectRef], FrameList))+primitivePatPatternMatch PPWildCard patObjRef = return $ Just ([patObjRef], [])+primitivePatPatternMatch (PPValuePat name) patObjRef = do+ patObj <- cRefEval1 patObjRef+ case patObj of+ Value (ValuePat objRef) -> return $ Just ([], [((name, []), objRef)])+ _ -> return $ Nothing+primitivePatPatternMatch (PPInductivePat ppcons pppats) patObjRef = do+ patObj <- cRefEval1 patObjRef+ case patObj of+ Intermidiate (IInductiveData pcon patObjRefs) ->+ if ppcons == pcon+ then primitivePatPatternMatchList pppats patObjRefs+ else return Nothing+ Value (InductiveData pcon patVals) -> do+ patObjRefs <- liftIO $ mapM (newIORef . Value) patVals+ if ppcons == pcon+ then primitivePatPatternMatchList pppats patObjRefs+ else return Nothing+ _ -> return $ Nothing +primitivePatPatternMatchList :: [PrimitivePatPattern] -> [ObjectRef] -> IOThrowsError (Maybe ([ObjectRef], FrameList))+primitivePatPatternMatchList [] [] = return $ Just ([], [])+primitivePatPatternMatchList (pppat:pppats) (patObjRef:patObjRefs) = do+ mRet <- primitivePatPatternMatch pppat patObjRef+ case mRet of+ Nothing -> return Nothing+ Just (retPatObjRefs, retFrame) -> do+ mRetRest <- primitivePatPatternMatchList pppats patObjRefs+ case mRetRest of+ Nothing -> return Nothing+ Just (retRestPatObjRefs, retRestFrame) -> return $ Just (retPatObjRefs ++ retRestPatObjRefs, retFrame ++ retRestFrame)+ primitivePatternMatch :: PrimitivePattern -> ObjectRef -> IOThrowsError (Maybe FrameList) primitivePatternMatch (PPatBool bool) objRef = do val <- cRefEval objRef
hs-src/Language/Egison/Parser.hs view
@@ -291,7 +291,7 @@ parseValuePat :: Parser EgisonExpr parseValuePat = do char ',' expr <- parseExpr- return $ PredPatExpr "=" [expr]+ return $ ValuePatExpr expr parseInnerExpr :: Parser InnerExpr parseInnerExpr = do expr <- parseExpr@@ -322,17 +322,29 @@ parseDestructInfoExpr :: Parser DestructInfoExpr parseDestructInfoExpr = braces (sepEndBy parseDestructClause whiteSpace) -parseDestructClause :: Parser (String, EgisonExpr, [(PrimitivePattern, EgisonExpr)])-parseDestructClause = brackets (do patCons <- lexeme identifier+parseDestructClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitivePattern, EgisonExpr)])+parseDestructClause = brackets (do pppat <- lexeme parsePrimitivePatPattern typExpr <- lexeme parseExpr dc2s <- lexeme (braces (sepEndBy parseDestructClause2 whiteSpace))- return (patCons, typExpr, dc2s))+ return (pppat, typExpr, dc2s)) parseDestructClause2 :: Parser (PrimitivePattern, EgisonExpr) parseDestructClause2 = brackets (do datPat <- lexeme parsePrimitivePattern expr <- lexeme parseExpr return (datPat, expr)) +parsePrimitivePatPattern :: Parser PrimitivePatPattern+parsePrimitivePatPattern =+ do char '_'+ return PPWildCard+ <|> do char ','+ char '$'+ name <- lexeme identifier+ return (PPValuePat name)+ <|> angles (do c <- lexeme identifier+ ps <- sepEndBy parsePrimitivePatPattern whiteSpace+ return (PPInductivePat c ps))+ parsePrimitivePattern :: Parser PrimitivePattern parsePrimitivePattern = do char '_'
hs-src/Language/Egison/Types.hs view
@@ -89,6 +89,7 @@ | VarOmitExpr EgisonExpr | PatVarExpr String [EgisonExpr] | WildCardExpr+ | ValuePatExpr EgisonExpr | CutPatExpr EgisonExpr | NotPatExpr EgisonExpr | AndPatExpr [EgisonExpr]@@ -117,6 +118,11 @@ type MatchClause = (EgisonExpr, EgisonExpr) +data PrimitivePatPattern = PPWildCard+ | PPValuePat String+ | PPInductivePat String [PrimitivePatPattern]+ deriving (Show)+ data PrimitivePattern = PWildCard | PPatVar String | PInductivePat String [PrimitivePattern]@@ -137,7 +143,7 @@ type RecursiveBindings = [(String, EgisonExpr)] -type DestructInfoExpr = [(String, EgisonExpr, [(PrimitivePattern, EgisonExpr)])]+type DestructInfoExpr = [(PrimitivePatPattern, EgisonExpr, [(PrimitivePattern, EgisonExpr)])] -- -- Value@@ -157,6 +163,7 @@ | Float Double | WildCard | PatVar String [Integer]+ | ValuePat ObjectRef | PredPat String [ObjectRef] | CutPat ObjectRef | NotPat ObjectRef@@ -216,7 +223,7 @@ data InnerValRef = IElement ObjectRef | ISubCollection ObjectRef -type DestructInfo = [(String, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])]+type DestructInfo = [(PrimitivePatPattern, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])] -- -- Internal Data@@ -311,6 +318,7 @@ showExpr (MacroVarExpr name nums) = "%" ++ name ++ unwordsNumExprs nums showExpr (PatVarExpr name nums) = "$" ++ name ++ unwordsNumExprs nums showExpr WildCardExpr = "_"+showExpr (ValuePatExpr expr) = "," ++ showExpr expr showExpr (PatVarOmitExpr pvar) = "$~" ++ showExpr pvar showExpr (VarOmitExpr pvar) = "~" ++ showExpr pvar showExpr (CutPatExpr _) = "#<cut-pat>"@@ -399,6 +407,7 @@ showVal (Float contents) = show contents showVal WildCard = "_" showVal (PatVar name nums) = "$" ++ name ++ unwordsNums nums+showVal (ValuePat _) = "#<value-pat>" showVal (CutPat _) = "#<cut-pat>" showVal (NotPat _) = "#<not-pat>" showVal (AndPat _) = "#<and-pat>"@@ -411,6 +420,7 @@ showVal (Type _) = "#<type>" showVal (Destructor _) = "#<destructor>" showVal (Func _ _ _) = "(lambda [" ++ "..." ++ "] ...)"+showVal (Macro _ _ ) = "(macro [" ++ "..." ++ "] ...)" showVal (PrimitiveFunc _) = "#<primitive>" showVal (IOFunc _) = "#<IO primitive>" showVal (Port _ _) = "#<IO port>"
lib/core/base.egi view
@@ -9,20 +9,14 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor- {[true []+ {[<true> [] {[<true> {[]}] [#t {[]}] [_ {}]}]- [false []+ [<false> [] {[<false> {[]}] [#f {[]}]- [_ {}]}]})]- [$=- (lambda [$val $tgt]- (match [val tgt] [Bool Bool]- {[[<true> <true>] #t]- [[<false> <false>] #t]- [[_ _] #f]}))]}))+ [_ {}]}]})]})) (define $or (lambda [$b1 $b2]@@ -57,19 +51,12 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor- {[less []+ {[<less> [] {[<less> {[]}] [_ {}]}]- [equal []+ [<equal> [] {[<equal> {[]}] [_ {}]}]- [greater []+ [<greater> [] {[<greater> {[]}]- [_ {}]}]})]- [$=- (lambda [$val $tgt]- (match [val tgt] [Order Order]- {[[<less> <less>] #t]- [[<equal> <equal>] #t]- [[<greater> <greater>] #t]- [[_ _] #f]}))]}))+ [_ {}]}]})]}))
lib/core/collection.egi view
@@ -8,16 +8,27 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor- {[nil []+ {[,$val []+ {[$tgt (if (= tgt val)+ {[]}+ {})]}]+ [<nil> [] {[{} {[]}] [_ {}]}]- [cons [a (List a)]+ [<cons _ _> [a (List a)] {[{$x .$xs} {[x xs]}] [_ {}]}]- [snoc [a (List a)]+ [<snoc _ _> [a (List a)] {[{.$xs $x} {[x xs]}] [_ {}]}]- [join [(List a) (List a)]+ [<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)@@ -27,7 +38,7 @@ @(map (lambda [$as $bs] [{x @as} bs]) (loop-fn xs))}]}))]} (loop-fn tgt))]}]- [nioj [(List a) (List a)]+ [<nioj _ _> [(List a) (List a)] {[$tgt (letrec {[$loop-fn (lambda [$ts] (match ts (List a)@@ -193,13 +204,21 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor- {[nil []+ {[,$val []+ {[$tgt (if (= tgt val)+ {[]}+ {})]}]+ [<nil> [] {[{} {[]}] [_ {}]}]- [cons [a (Multiset a)]+ [<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 [(Multiset a) (Multiset a)]+ [<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]@@ -214,14 +233,18 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor- {[nil []+ {[,$val []+ {[$tgt (if (= tgt val)+ {[]}+ {})]}]+ [<nil> [] {[{} {[]}] [_ {}]}]- [cons [a (Set a)]+ [<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)]+ [<join _ _> [(Set a) (Set a)] {[$tgt (let {[$tgt2 ((unique a) tgt)]} (concat (map (lambda [$xs $ys] (map (lambda [$sxs] [xs {@ys @sxs}]) (subcollections xs)))
lib/core/number.egi view
@@ -1,6 +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))]})) (define $compare-integer@@ -14,6 +20,12 @@ (define $Double (type {[$var-match (lambda [$tgt] {tgt})]+ [$inductive-match+ (destructor+ {[,$d []+ {[$tgt (if (= tgt d)+ {[]}+ {})]}]})] [$= (lambda [$val $tgt] (eq-f? val tgt))]})) (define $compare-float@@ -29,10 +41,10 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor- {[o []+ {[<o> [] {[0 {[]}] [_ {}]}]- [s Nat+ [<s> Nat {[$tgt (match (compare-integer tgt 0) Order {[<greater> {(- tgt 1)}] [_ {}]})]}]})]
lib/graph.egi view
@@ -5,7 +5,11 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor- {[node [Node (Multiset Node) (Multiset Node)]+ {[,$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]
lib/poker-hands.egi view
@@ -3,16 +3,20 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor- {[spade []+ {[,$suit []+ {[$tgt (if (= tgt suit)+ {[]}+ {})]}]+ [<spade> [] {[<spade> {[]}] [_ {}]}]- [heart []+ [<heart> [] {[<heart> {[]}] [_ {}]}]- [club []+ [<club> [] {[<club> {[]}] [_ {}]}]- [diamond []+ [<diamond> [] {[<diamond> {[]}] [_ {}]}]})] [$=@@ -28,6 +32,12 @@ (lambda [$m] (type {[$var-match (lambda [$tgt] {(mod tgt m)})]+ [$inductive-match+ (destructor+ {[,$n []+ {[$tgt (if (= tgt n)+ {[]}+ {})]}]})] [$= (lambda [$val $tgt] (eq? (mod val m) (mod tgt m)))]}))) (define $Card@@ -35,7 +45,11 @@ {[$var-match (lambda [$tgt] {tgt})] [$inductive-match (destructor- {[card [Suit (Mod 13)]+ {[,$card []+ {[$tgt (if (= tgt card)+ {[]}+ {})]}]+ [<card _ _> [Suit (Mod 13)] {[<card $s $n> {[s n]}]}]})] [$= (lambda [$val $tgt] (match [val tgt] [Card Card]