diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 2.3.10 +Version: 2.4.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 @@ -19,6 +19,7 @@ "\\" "\\" + "\\" "\\" "\\\." 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 @@ -11,7 +11,6 @@ import qualified System.Exit () import System.Directory (doesFileExist) import System.IO -import System.IO.Strict (SIO) import qualified System.IO.Strict as SIO import Data.IORef import Data.Version @@ -63,7 +62,7 @@ argv <- cEval1 $ Closure env argvExpr argvRef <- liftIO $ newIORef argv worldRef <- liftIO $ newIORef $ Value $ World [] - argsRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ [IElement worldRef, IElement argvRef] + argsRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ [worldRef, argvRef] ret <- cApply1 mainRef argsRef cEval ret @@ -112,9 +111,9 @@ iEval (ICollection innerRefs) = do vals <- innerRefsEval innerRefs return $ Collection vals -iEval (ITuple innerRefs) = do - innerVals <- innerRefsEval innerRefs - return $ Tuple innerVals +iEval (ITuple objRefs) = do + vals <- mapM cRefEval objRefs + return $ Tuple vals innerRefsEval :: [InnerValRef] -> IOThrowsError [EgisonVal] innerRefsEval [] = return [] @@ -178,12 +177,11 @@ return $ Intermidiate $ IInductiveData cons args cEval1 (Closure _ (TupleExpr [])) = do return $ Value $ Tuple [] -cEval1 (Closure env (TupleExpr innerExprs)) = do - innerRefs <- liftIO $ mapM (makeInnerValRef env) innerExprs - objRefs <- innerRefsToObjRefs innerRefs +cEval1 (Closure env (TupleExpr exprs)) = do + objRefs <- liftIO $ mapM (makeClosure env) exprs case objRefs of [objRef] -> cRefEval1 objRef - _ -> return $ Intermidiate $ ITuple innerRefs + _ -> return $ Intermidiate $ ITuple objRefs cEval1 (Closure env (CollectionExpr innerExprs)) = do innerRefs <- liftIO $ mapM (makeInnerValRef env) innerExprs return $ Intermidiate $ ICollection innerRefs @@ -238,7 +236,8 @@ patObjRefs <- liftIO $ mapM (makeClosure env) patExprs return $ Value $ AndPat patObjRefs cEval1 (Closure env (FuncExpr args body)) = do - return $ Value $ Func args body env + argsObjRef <- liftIO $ makeClosure env args + return $ Value $ Func argsObjRef body env cEval1 (Closure _ (MacroExpr args body)) = do return $ Value $ Macro args body cEval1 (Closure env (IfExpr condExpr expr1 expr2)) = do @@ -312,7 +311,8 @@ Value (PrimitiveFunc fn) -> do arg <- eval env argExpr val <- liftThrows $ fn (tupleToList arg) return $ Value val - Value (Func fArgs body cEnv) -> do frame <- liftIO (makeClosure env argExpr) >>= makeFrame fArgs + Value (Func fArgs body cEnv) -> do argObjRef <- liftIO $ makeClosure env argExpr + frame <- makeFrame fArgs argObjRef newEnv <- liftIO $ extendEnv cEnv frame cEval1 (Closure newEnv body) Value (Macro mArgs body) -> do argExprs <- liftThrows $ tupleExprToExprList argExpr @@ -320,6 +320,8 @@ liftIO $ putStrLn $ showExpr newBody cEval1 (Closure env newBody) _ -> throwError $ Default "not function" +cEval1 (Closure _ UndefinedExpr) = do + throwError ReachToUndefined cEval1 val = do return val @@ -366,47 +368,39 @@ cEval1 $ Closure newEnv loopExpr expandLoop _ obj = throwError $ Default $ "expandLoop: cannot reach here: " ++ show obj --- |Extend given environment by binding a series of values to a new environment for let. extendLet :: Env -- ^ Environment - -> [(Args, EgisonExpr)] -- ^ Extensions to the environment + -> [(EgisonExpr, EgisonExpr)] -- ^ Extensions to the environment -> IOThrowsError Env -- ^ Extended environment -extendLet env abindings = do - bingingList <- liftM concat $ mapM (\(args, expr) -> do - objRef <- liftIO $ makeClosure env expr - helper args objRef) - abindings - liftIO $ extendEnv env bingingList - where helper (AVar name) objRef = return [((name, []), objRef)] - helper (ATuple argss) objRef = do - obj <- cRefEval1 objRef - case obj of - Intermidiate (ITuple innerRefs) -> do - objRefs <- innerValRefsToObjRefs innerRefs - liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss objRefs - Value (Tuple vals) -> do - objRefs <- liftIO $ mapM (newIORef . Value) vals - liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss objRefs - _ -> liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss [objRef] +extendLet env binding = do + frame <- helper binding + liftIO $ extendEnv env frame + where helper :: [(EgisonExpr, EgisonExpr)] -> IOThrowsError FrameList + helper [] = return [] + helper ((patExpr, tgtExpr):rest) = do + patObjRef <- liftIO $ makeClosure env patExpr + tgtObjRef <- liftIO $ makeClosure env tgtExpr + frame <- makeFrame patObjRef tgtObjRef + retRest <- helper rest + return $ frame ++ retRest -makeFrame :: Args -> ObjectRef -> IOThrowsError [(Var, ObjectRef)] -makeFrame (AVar name) objRef = return $ [((name,[]), objRef)] -makeFrame (ATuple []) _ = return $ [] -makeFrame (ATuple [fArg]) objRef = makeFrame fArg objRef -makeFrame (ATuple fArgs) objRef = do - obj <- cRefEval1 objRef - case obj of - Intermidiate (ITuple innerRefs) -> do - objRefs <- innerValRefsToObjRefs innerRefs - frames <- mapM (\(fArg,objRef3) -> makeFrame fArg objRef3) $ zip fArgs objRefs - return $ concat frames - Value (Tuple vals) -> do - objRefs <- liftIO $ mapM (newIORef . Value) vals - frames <- mapM (\(fArg,objRef3) -> makeFrame fArg objRef3) $ zip fArgs objRefs - return $ concat frames - _ -> throwError $ Default "makeFrame: not tuple" +makeFrame :: ObjectRef -> ObjectRef -> IOThrowsError FrameList +makeFrame patObjRef tgtObjRef = do + patObjRefs <- tupleToObjRefs patObjRef + let n = length patObjRefs + if n == 1 + then do typObjRef <- liftIO $ newIORef $ Value Something + matchs <- patternMatch MOne [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])] + case matchs of + [match] -> return match + _ -> throwError $ Default "makeFrame: binding error" + else do typObjRef <- liftIO $ newIORef $ (Value . Tuple) $ replicate (length patObjRefs) Something + matchs <- patternMatch MOne [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])] + case matchs of + [match] -> do return match + _ -> throwError $ Default "makeFrame: binding error" tupleExprToExprList :: EgisonExpr -> ThrowsError [EgisonExpr] -tupleExprToExprList (TupleExpr innerExprs) = innerExprsToExprList innerExprs +tupleExprToExprList (TupleExpr exprs) = return exprs tupleExprToExprList expr = return [expr] innerExprsToExprList :: [InnerExpr] -> ThrowsError [EgisonExpr] @@ -504,18 +498,35 @@ 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 <- innerRefsToObjRefs pats - tgtObjRefs <- tupleToObjRefs tgtObjRef + Intermidiate (ITuple patObjRefs) -> do typObjRefs <- tupleToObjRefs typObjRef - patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states + if length typObjRefs == 1 + then do + let tgtObjRefs = [tgtObjRef] + if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs) + then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states + else throwError $ Default "patternMatch: number of types, patterns and targets are different" + else do + tgtObjRefs <- tupleToObjRefs tgtObjRef + if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs) + then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states + else throwError $ Default "patternMatch: number of types, patterns and targets are different" Value (Tuple pats) -> do patObjRefs <- liftIO $ mapM (newIORef . Value) pats - tgtObjRefs <- tupleToObjRefs tgtObjRef typObjRefs <- tupleToObjRefs typObjRef - patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states + if length typObjRefs == 1 + then do + let tgtObjRefs = [tgtObjRef] + if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs) + then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states + else throwError $ Default "patternMatch: number of types, patterns and targets are different" + else do + tgtObjRefs <- tupleToObjRefs tgtObjRef + if (length typObjRefs == length patObjRefs) && (length typObjRefs == length tgtObjRefs) + then patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states + else throwError $ Default "patternMatch: number of types, patterns and targets are different" Value (PredPat predObjRef patObjRefs) -> do - argsObjRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ map IElement $ patObjRefs ++ [tgtObjRef] + argsObjRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ patObjRefs ++ [tgtObjRef] ret <- cApply1 predObjRef argsObjRef case ret of Value (Bool True) -> patternMatch flag ((MState frame atoms):states) @@ -551,9 +562,13 @@ mPpmRet <- helper pclss case mPpmRet of Nothing -> throwError $ Default "inductiveMatch: not matched any primitive clauses" - Just tgtObjRefss -> do + Just tgtObjRefs -> do typObjRefs <- tupleToObjRefs typObjRef - return (typObjRefs, patObjRefs, tgtObjRefss) + if length typObjRefs == 1 + then do let tgtObjRefss = map (\x -> [x]) tgtObjRefs + return (typObjRefs, patObjRefs, tgtObjRefss) + else do tgtObjRefss <- mapM tupleToObjRefs tgtObjRefs + return (typObjRefs, patObjRefs, tgtObjRefss) where helper [] = return Nothing helper ((env, ppat, expr):pclss2) = do mPpmRet <- primitivePatternMatch ppat tgtObjRef @@ -563,8 +578,7 @@ newEnv <- liftIO $ extendEnv env (ppmRet ++ frame) retObjRef <- liftIO $ makeClosure newEnv expr tgtObjRefs <- collectionToObjRefs retObjRef - tgtObjRefss <- mapM tupleToObjRefs tgtObjRefs - return $ Just tgtObjRefss + return $ Just tgtObjRefs primitivePatPatternMatch :: PrimitivePatPattern -> ObjectRef -> IOThrowsError (Maybe ([ObjectRef], FrameList)) primitivePatPatternMatch PPWildCard patObjRef = return $ Just ([patObjRef], []) @@ -783,7 +797,7 @@ tupleToObjRefs objRef = do obj <- cRefEval1 objRef case obj of - Intermidiate (ITuple innerRefs) -> innerRefsToObjRefs innerRefs + Intermidiate (ITuple objRefs) -> return objRefs Value (Tuple vals) -> liftIO $ mapM (newIORef . Value) vals _ -> return [objRef] @@ -905,9 +919,6 @@ ("&&", boolBinop (&&)), ("||", boolBinop (||)), - - ("tuple-to-collection", tupleToCollection), - ("collection-to-tuple", collectionToTuple), ("array-dimension", arrayDimension), ("array-range", arrayRange), 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 @@ -10,7 +10,7 @@ expandMacro :: MacroFrame -> EgisonExpr -> IOThrowsError EgisonExpr expandMacro frame (VarExpr name []) = case getExpr frame name of - Nothing -> return $ MacroVarExpr name [] + Nothing -> return $ VarExpr name [] Just expr -> return expr expandMacro frame (PatVarOmitExpr expr) = do newExpr <- expandMacro frame expr @@ -25,9 +25,9 @@ expandMacro frame (InductiveDataExpr cons exprs) = do newExprs <- mapM (expandMacro frame) exprs return $ InductiveDataExpr cons newExprs -expandMacro frame (TupleExpr innerExprs) = do - newInnerExprs <- mapM (expandMacroInnerExpr frame) innerExprs - return $ TupleExpr newInnerExprs +expandMacro frame (TupleExpr exprs) = do + newExprs <- mapM (expandMacro frame) exprs + return $ TupleExpr newExprs expandMacro frame (CollectionExpr innerExprs) = do newInnerExprs <- mapM (expandMacroInnerExpr frame) innerExprs return $ CollectionExpr newInnerExprs @@ -75,6 +75,10 @@ newTypExpr <- expandMacro frame typExpr newMc <- expandMacroMatchClause frame mc return $ MatchAllExpr newTgtExpr newTypExpr newMc +expandMacro frame (ApplyExpr opExpr argExpr) = do + newOpExpr <- expandMacro frame opExpr + newArgExpr <- expandMacro frame argExpr + return $ ApplyExpr newOpExpr newArgExpr expandMacro _ expr = return expr expandMacroMatchClause :: MacroFrame -> MatchClause -> IOThrowsError MatchClause diff --git a/hs-src/Language/Egison/Numerical.hs b/hs-src/Language/Egison/Numerical.hs --- a/hs-src/Language/Egison/Numerical.hs +++ b/hs-src/Language/Egison/Numerical.hs @@ -1,10 +1,6 @@ module Language.Egison.Numerical where import Language.Egison.Types import Control.Monad.Error ---import Data.Char hiding (isNumber) ---import Data.Fixed ---import Numeric ---import Text.Printf import Data.Array boolBinop :: (Bool -> Bool -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal @@ -162,18 +158,6 @@ unpackFloat :: EgisonVal -> ThrowsError Double unpackFloat (Float n) = return n unpackFloat notFloat = throwError $ TypeMismatch "float" [notFloat] - - -tupleToCollection :: [EgisonVal] -> ThrowsError EgisonVal -tupleToCollection vals = return $ Collection $ vals - -collectionToTuple :: [EgisonVal] -> ThrowsError EgisonVal -collectionToTuple [(Collection vals)] = do - case vals of - [val] -> return val - _ -> return $ Tuple vals -collectionToTuple [x] = throwError $ TypeMismatch "collection" [x] -collectionToTuple badArgList = throwError $ NumArgs 1 badArgList stringToChars :: [EgisonVal] -> ThrowsError EgisonVal stringToChars [(String str)] = return $ Collection $ map Char str 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 @@ -2,13 +2,9 @@ import Language.Egison.Types import Control.Monad.Error import qualified Data.Char as Char -import Data.Complex -import Data.Array import Numeric -import Data.Ratio import Text.ParserCombinators.Parsec hiding (spaces) import Text.Parsec.Language -import Text.Parsec.Prim (ParsecT) import qualified Text.Parsec.Token as P egisonDef :: LanguageDef () @@ -256,7 +252,7 @@ parseBindings :: Parser Bindings parseBindings = do - braces (do sepEndBy (brackets (do args <- lexeme parseArgs + braces (do sepEndBy (brackets (do args <- lexeme parseExpr expr <- lexeme parseExpr return (args, expr))) whiteSpace) @@ -404,6 +400,8 @@ <|> lexeme parseMacroVarExpr <|> lexeme parsePatVarOmitExpr <|> lexeme parseVarOmitExpr + <|> try (lexeme (do string "undefined" + return UndefinedExpr)) <|> try (lexeme (do string "Something" return SomethingExpr)) <|> lexeme parseVar @@ -416,10 +414,10 @@ return $ InductiveDataExpr cons argExprs) <|> braces (do innerExprs <- sepEndBy parseInnerExpr whiteSpace return $ CollectionExpr innerExprs) - <|> brackets (do innerExprs <- sepEndBy parseInnerExpr whiteSpace - return $ TupleExpr innerExprs) + <|> brackets (do exprs <- sepEndBy parseExpr whiteSpace + return $ TupleExpr exprs) <|> parens (do try (string "lambda" >> many1 space) - args <- lexeme parseArgs + args <- lexeme parseExpr body <- lexeme parseExpr return (FuncExpr args body) <|> do try (string "macro" >> many1 space) @@ -471,7 +469,7 @@ return (GenerateArrayExpr fnExpr arrExpr) <|> do opExpr <- lexeme parseExpr argExprs <- sepEndBy parseExpr whiteSpace - return (ApplyExpr opExpr (TupleExpr (map ElementExpr argExprs)))) + return (ApplyExpr opExpr (TupleExpr argExprs))) "Expression" parseTopExpr :: Parser TopExpr diff --git a/hs-src/Language/Egison/Primitives.hs b/hs-src/Language/Egison/Primitives.hs --- a/hs-src/Language/Egison/Primitives.hs +++ b/hs-src/Language/Egison/Primitives.hs @@ -234,8 +234,8 @@ exprToVal (CollectionExpr innerExprs) = do vals <- innerExprsToVals innerExprs return $ Collection vals -exprToVal (TupleExpr innerExprs) = do - vals <- innerExprsToVals innerExprs +exprToVal (TupleExpr exprs) = do + vals <- mapM exprToVal exprs return $ Tuple vals exprToVal _ = throwError $ Default "read: invalid value" 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 @@ -17,6 +17,7 @@ | NotFunction String String | UnboundVar String String | DivideByZero + | ReachToUndefined | NotImplemented String | InternalError String | Default String @@ -30,7 +31,8 @@ showError (BadSpecialForm message args) = message ++ ": " ++ unwordsList args showError (NotFunction message func) = message ++ ": " ++ show func showError (UnboundVar message varname) = message ++ ": " ++ varname -showError (DivideByZero) = "Division by zero" +showError DivideByZero = "Division by zero" +showError ReachToUndefined = "Reached to undefined" showError (NotImplemented message) = "Not implemented: " ++ message showError (InternalError message) = "An internal error occurred: " ++ message showError (Default message) = "Error: " ++ message @@ -93,10 +95,10 @@ | OrPatExpr [EgisonExpr] | PredPatExpr EgisonExpr [EgisonExpr] | InductiveDataExpr String [EgisonExpr] - | TupleExpr [InnerExpr] + | TupleExpr [EgisonExpr] | CollectionExpr [InnerExpr] | ArrayExpr [ArrayElementExpr] - | FuncExpr Args EgisonExpr + | FuncExpr EgisonExpr EgisonExpr | MacroExpr [String] EgisonExpr | LoopExpr String String EgisonExpr EgisonExpr EgisonExpr | ParamsExpr String EgisonExpr EgisonExpr @@ -110,6 +112,7 @@ | GenerateArrayExpr EgisonExpr EgisonExpr | ApplyExpr EgisonExpr EgisonExpr | SomethingExpr + | UndefinedExpr deriving (Show) data ArrayElementExpr = AElementExpr EgisonExpr @@ -141,7 +144,7 @@ | SubCollectionExpr EgisonExpr deriving (Show) -type Bindings = [(Args, EgisonExpr)] +type Bindings = [(EgisonExpr, EgisonExpr)] type RecursiveBindings = [(String, EgisonExpr)] @@ -176,7 +179,7 @@ | Collection [EgisonVal] | Array Integer [Integer] (Array Integer EgisonVal) | Type DestructInfo - | Func Args EgisonExpr Env + | Func ObjectRef EgisonExpr Env | Macro [String] EgisonExpr | PrimitiveFunc ([EgisonVal] -> ThrowsError EgisonVal) | IOFunc ([EgisonVal] -> IOThrowsError EgisonVal) @@ -185,7 +188,7 @@ | EOF data IntermidiateVal = IInductiveData String [ObjectRef] - | ITuple [InnerValRef] + | ITuple [ObjectRef] | ICollection [InnerValRef] data Action = OpenInputPort String @@ -337,6 +340,7 @@ showExpr (ApplyExpr opExpr argExpr) = "(" ++ showExpr opExpr ++ " " ++ showExpr argExpr ++ ")" showExpr SomethingExpr = "Something" +showExpr UndefinedExpr = "undefined" ---- |Allow conversion of egisonexpr instances to strings --instance Show EgisonExpr where show = showExpr diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -34,20 +34,20 @@ [[_ _] {}]}))]} (helper pys tgt))]}] [ [(List a) (List a)] - {[$tgt (letrec {[$helper (lambda [$xs $ys $r] + {[$tgt (letrec {[$helper (lambda [$xs $ys] (match ys (List a) - {[ {[xs {}] @r}] - [ (helper {@xs z} zs {[xs ys] @r})]}))]} - (helper {} tgt {}))]}] + {[ {[xs {}]}] + [ {[xs ys] @(helper {@xs z} zs {[xs ys]})}]}))]} + (helper {} tgt))]}] [ [(List a)] {[$tgt (match-all tgt (List a) [ ys])]}] [ [(List a)] {[$tgt (match-all tgt (List a) [ xs])]}] [ [(List a) (List a)] - {[$tgt (letrec {[$helper (lambda [$xs $ys $r] + {[$tgt (letrec {[$helper (lambda [$xs $ys] (match ys (List a) - {[ {[{} xs] @r}] - [ (helper {@xs z} zs {[ys xs] @r})]}))]} + {[ {[{} xs]}] + [ {[ys xs] @(helper {@xs z} zs)}]}))]} (helper {} tgt {}))]}] [_ [Something] {[$tgt {tgt}]}] @@ -121,11 +121,10 @@ (define $subcollections (lambda [$xs] (match xs (List Something) - {[ {{}}] - [ - (let {[$subs (subcollections rs)]} - {@subs @(map (lambda [$sub] {x @sub}) - subs)})]}))) + {[ {{}}] + [ + (let {[$subs (subcollections rs)]} + {@subs @(map (lambda [$sub] {x @sub}) subs)})]}))) (define $size (lambda [$xs] @@ -153,11 +152,8 @@ (match xs (List Something) {[ ys]}))) -(define $nth - (lambda [$n $ls] - (if (eq-n? n 1) - (car ls) - (nth (- n 1) (cdr ls))))) +(define $nth (lambda [$i $l] + (match l (List Something) {[ (if (eq? i 0) x (nth (- i 1) xs))]}))) (define $reverse (lambda [$xs] @@ -195,7 +191,6 @@ (if ((member? a) x ys) ((subcollection? a) rest ys) #f)]})))) - (define $concat (lambda [$xs] @@ -215,16 +210,26 @@ {[{} {[]}] [_ {}]}] [ [(Multiset a)] - {[$tgt (if ((member? a) px tgt) - {((remove a) tgt px)} - {})]}] + {[$tgt (letrec {[$helper (lambda [$xs $ys] + (match xs (List a) + {[ {}] + [ {{@ys @zs}}] + [ (helper zs {@ys z})]}))]} + (helper tgt {}))]}] [ [a (Multiset a)] - {[$tgt (map (lambda [$t] [t ((remove a) tgt t)]) - ((unique a) tgt))]}] + {[$tgt (letrec {[$helper (lambda [$xs $ys] + (match ys (List a) + {[ {}] + [ (if ((member? a) z xs) + (helper {@xs z} zs) + {[z {@xs @zs}] @(helper {@xs z} zs)})]}))]} + (helper {} tgt))]}] [ [(Multiset a)] {[$tgt (if ((subcollection? a) pxs tgt) {((remove-collection a) tgt pxs)} {})]}] + [ [(Multiset a)] + {[$tgt (match-all tgt (Multiset a) [ xs])]}] [ [(Multiset a) (Multiset a)] {[$tgt (map (lambda [$ts] [ts ((remove-collection a) tgt ts)]) (subcollections tgt))]}] @@ -243,10 +248,21 @@ [ [] {[{} {[]}] [_ {}]}] + [ [(Set a)] + {[$tgt (letrec {[$helper (lambda [$xs $ys] + (match xs (List a) + {[ {}] + [ {{@ys @zs} tgt}] + [ (helper zs {@ys z})]}))]} + (helper ((unique a) tgt) {}))]}] [ [a (Set a)] {[$tgt (let {[$tgt2 ((unique a) tgt)]} - {@(match-all tgt2 (Multiset a) [ [x xs]]) - @(match-all tgt2 (Multiset a) [ [x {@xs x}]])})]}] + (letrec {[$helper (lambda [$xs $ys] + (match xs (List a) + {[ {}] + [ + {[z {@ys @zs}] [z tgt2] @(helper zs {@ys z})}]}))]} + (helper tgt2 {})))]}] [ [(Set a) (Set a)] {[$tgt (let {[$tgt2 ((unique a) tgt)]} (concat (map (lambda [$xs $ys] (map (lambda [$sxs] [xs {@ys @sxs}]) diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -17,7 +17,7 @@ )))) -(define $Double +(define $Float (type {[,$d [] {[$tgt (if (eq-f? tgt d) diff --git a/lib/graph.egi b/lib/graph.egi --- a/lib/graph.egi +++ b/lib/graph.egi @@ -40,7 +40,7 @@ l> _> _>)> - [@(loop $l $i (between 1 n) {a_i @l} {})]])))) + (loop $l $i (between 1 n) {a_i @l} {})])))) (define $hamilton-path (lambda [$g] @@ -52,5 +52,5 @@ l> >)> - [@(loop $l $i (between 1 n) {a_i @l} {})]])))) + (loop $l $i (between 1 n) {a_i @l} {})])))) diff --git a/sample/n-queen.egi b/sample/n-queen.egi --- a/sample/n-queen.egi +++ b/sample/n-queen.egi @@ -10,4 +10,4 @@ $a_i) l> )> - [@(loop $l $i (between 1 n) {a_i @l} {})]]))) + (loop $l $i (between 1 n) {a_i @l} {})])))