diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 2.2.2 +Version: 2.2.3 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. @@ -16,8 +16,8 @@ Build-type: Simple Cabal-version: >=1.8 -Data-files: lib/core/base.egi lib/core/number.egi lib/core/collection.egi lib/graph.egi lib/poker-hands.egi - sample/number-test.egi sample/collection-test.egi sample/graph-test.egi +Data-files: lib/core/base.egi lib/core/number.egi lib/core/collection.egi lib/core/array.egi lib/graph.egi lib/poker-hands.egi + sample/number-test.egi sample/collection-test.egi sample/array-test.egi sample/graph-test.egi sample/poker-hands-test.egi sample/compile-test.egi sample/io/argv-test.egi sample/io/cat.egi sample/io/copy.egi sample/io/char-test.egi sample/io/hello.egi sample/io/read-write-test.egi elisp/egison-mode.el diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -20,6 +20,7 @@ "\\" "\\" "\\" + "\\" "\\\." "\\\," @@ -110,6 +111,7 @@ ((equal "match-all" name) 2) ((equal "type" name) 2) ((equal "destructor" name) 2) + ((equal "generate-array" name) 2) )) (defun egison-indent-line () 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 @@ -287,16 +287,15 @@ rangeObjRef <- liftIO $ makeClosure env rangeExpr let loopObj = Loop loopVar indexVar rangeObjRef loopExpr tailExpr expandLoop env loopObj -cEval1 (Closure env (ArrayMapExpr fnExpr arrExpr)) = do +cEval1 (Closure env (GenerateArrayExpr fnExpr rangeExpr)) = do fnObjRef <- liftIO $ makeClosure env fnExpr - arrObj <- cEval1 (Closure env arrExpr) - case arrObj of - Value (Array d ms _) -> do - let is = map (\iss -> (Value . Tuple) $ map (Element . Number) iss) $ indexList ms - isRefs <- liftIO $ mapM newIORef is - vals <- mapM (cApply fnObjRef) isRefs - return $ Value $ Array d ms $ listArray (1, (fromIntegral (length vals))) vals - _ -> throwError $ Default "array-map: not array" + rangeVal <- eval env rangeExpr + ms <- liftThrows $ mapM unpackNum $ tupleToList rangeVal + let d = fromIntegral $ length ms + let is = map (\iss -> (Value . Tuple) $ map (Element . Number) iss) $ indexList ms + isRefs <- liftIO $ mapM newIORef is + vals <- mapM (cApply fnObjRef) isRefs + return $ Value $ Array d ms $ listArray (1, (fromIntegral (length vals))) vals cEval1 (Closure env (ApplyExpr opExpr argExpr)) = do op <- cEval1 (Closure env opExpr) case op of @@ -991,11 +990,20 @@ ("eq-c?", charBoolBinop (==)), ("eq-s?", strBoolBinop (==)), + + ("string-append", stringBinop (++)), + ("string-to-chars", stringToChars), + ("chars-to-string", charsToString), + ("&&", boolBinop (&&)), ("||", boolBinop (||)), + ("tuple-to-collection", tupleToCollection), + ("collection-to-tuple", collectionToTuple), + ("array-dimension", arrayDimension), + ("array-range", arrayRange), ("array-size", arraySize), ("array-keys", arrayKeys), 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 @@ -31,6 +31,10 @@ floatBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal floatBinop op aparams = mapM unpackFloat aparams >>= return . Float . foldl1 op +stringBinop :: (String -> String -> String) -> [EgisonVal] -> ThrowsError EgisonVal +stringBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal +stringBinop op aparams = mapM unpackString aparams >>= return . String . foldl1 op + charBoolBinop :: (Char -> Char -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal charBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal charBoolBinop op aparams = mapM unpackChar aparams >>= doOp @@ -129,7 +133,6 @@ -- - end Numeric operations section - -- |Extract an bool from the given value, throwing a type error if -- the wrong type is passed. unpackBool :: EgisonVal -> ThrowsError Bool @@ -161,6 +164,34 @@ unpackFloat notFloat = throwError $ TypeMismatch "float" [notFloat] +tupleToCollection :: [EgisonVal] -> ThrowsError EgisonVal +tupleToCollection vals = return $ Collection $ map Element vals + +collectionToTuple :: [EgisonVal] -> ThrowsError EgisonVal +collectionToTuple [(Collection innerVals)] = do + let vals = innerValsToList innerVals + case vals of + [val] -> return val + _ -> return $ Tuple $ map Element vals +collectionToTuple [x] = throwError $ TypeMismatch "collection" [x] +collectionToTuple badArgList = throwError $ NumArgs 1 badArgList + +stringToChars :: [EgisonVal] -> ThrowsError EgisonVal +stringToChars [(String str)] = return $ Collection $ map (\c -> Element $ Char c) str +stringToChars [x] = throwError $ TypeMismatch "string" [x] +stringToChars badArgList = throwError $ NumArgs 1 badArgList + +charsToString :: [EgisonVal] -> ThrowsError EgisonVal +charsToString [(Collection innerVals)] = do + let chars = innerValsToList innerVals + cs <- mapM (\char -> case char of + Char c -> return c + _ -> throwError $ TypeMismatch "chars" [char]) + chars + return $ String cs +charsToString [x] = throwError $ TypeMismatch "collection of chars" [x] +charsToString badArgList = throwError $ NumArgs 1 badArgList + --------------------------------------------------- -- Array --------------------------------------------------- @@ -170,6 +201,11 @@ arrayDimension [x] = throwError $ TypeMismatch "array" [x] arrayDimension badArgList = throwError $ NumArgs 1 badArgList +arrayRange :: [EgisonVal] -> ThrowsError EgisonVal +arrayRange [(Array _ ns _)] = return $ Tuple $ map (Element . Number) ns +arrayRange [x] = throwError $ TypeMismatch "array" [x] +arrayRange badArgList = throwError $ NumArgs 1 badArgList + arraySize :: [EgisonVal] -> ThrowsError EgisonVal arraySize [(Number m), (Array _ ns _)] = return $ Number $ nth m ns arraySize [x, y] = throwError $ TypeMismatch "number, array" [x, y] @@ -191,7 +227,6 @@ helper (n:ns) (m:ms) = if (n > 0 && n <= m) then helper ns ms else False - arrayIsRange [x, y] = throwError $ TypeMismatch "key, array" [x, y] arrayIsRange badArgList = throwError $ NumArgs 2 badArgList 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 @@ -481,10 +481,10 @@ loopExpr <- lexeme parseExpr tailExpr <- lexeme parseExpr return (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr) - <|> do try (string "array-map" >> many1 space) + <|> do try (string "generate-array" >> many1 space) fnExpr <- lexeme parseExpr arrExpr <- lexeme parseExpr - return (ArrayMapExpr fnExpr arrExpr) + return (GenerateArrayExpr fnExpr arrExpr) <|> do opExpr <- lexeme parseExpr argExprs <- sepEndBy parseExpr whiteSpace return (ApplyExpr opExpr (TupleExpr (map ElementExpr argExprs)))) 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 @@ -110,7 +110,7 @@ | DestructorExpr DestructInfoExpr | MatchExpr EgisonExpr EgisonExpr [MatchClause] | MatchAllExpr EgisonExpr EgisonExpr MatchClause - | ArrayMapExpr EgisonExpr EgisonExpr + | GenerateArrayExpr EgisonExpr EgisonExpr | ApplyExpr EgisonExpr EgisonExpr deriving (Show) @@ -361,8 +361,8 @@ "(match " ++ showExpr tgtExpr ++ " " ++ showExpr typExpr ++ " ...)" showExpr (MatchAllExpr tgtExpr typExpr _) = "(match-all " ++ showExpr tgtExpr ++ " " ++ showExpr typExpr ++ " ...)" -showExpr (ArrayMapExpr fnExpr arrExpr) = - "(array-map " ++ showExpr fnExpr ++ " " ++ showExpr arrExpr ++ " )" +showExpr (GenerateArrayExpr fnExpr arrExpr) = + "(generate-array " ++ showExpr fnExpr ++ " " ++ showExpr arrExpr ++ " )" showExpr (ApplyExpr opExpr argExpr) = "(" ++ showExpr opExpr ++ " " ++ showExpr argExpr ++ ")" diff --git a/lib/core/array.egi b/lib/core/array.egi new file mode 100644 --- /dev/null +++ b/lib/core/array.egi @@ -0,0 +1,37 @@ +;; +;; Array.egi +;; + +(define $Array + (lambda [$a] + (type + {[$var-match (lambda [$tgt] {tgt})] + [$inductive-match + (destructor + {[ [a (Array a)] + {[$arr (if (array-range? key arr) + {[(array-ref key arr) arr]} + {})]}]})]}))) + +(define $range-to-keys + (lambda $ms + (letrec {[$range-to-keys2 + (lambda [$ms] + (match ms (List Integer) + {[ {{}}] + [ + (let {[$iss (range-to-keys2 ns)]} + (concat (map (lambda [$i] + (map (lambda [$is] {i @is}) + iss)) + (between 1 n))))]}))]} + (map collection-to-tuple (range-to-keys2 (tuple-to-collection ms)))))) + +(define $keys-for-display + (lambda [$mx $my] + (let {[$xs (between 1 mx)] + [$ys (reverse (between 1 my))]} + (map (lambda [$y] + (map (lambda [$x] [x y]) + xs)) + ys)))) diff --git a/sample/array-test.egi b/sample/array-test.egi new file mode 100644 --- /dev/null +++ b/sample/array-test.egi @@ -0,0 +1,30 @@ +(define $ass [|[~1 2 3~] + [~4 5 6~] + [~7 8 9~] + [~10 11 12~]|]) + +(test (array-dimension ass)) + +(test (array-size 1 ass)) + +(test (array-size 2 ass)) + +(test (array-range ass)) + +(test (array-ref [2 2] ass)) + +(test (array-ref [2 3] ass)) + +(test (array-range? [2 3] ass)) + +(test (array-range? [2 4] ass)) + +(test (generate-array (lambda [$i1 $i2] (* (array-ref [i1 i2] ass) 2)) (array-range ass))) + +(define $bss (generate-array (lambda [$i1 $i2] (* (array-ref [i1 i2] ass) 2)) (array-range ass))) + +(test (array-ref [2 3] bss)) + +(test (match ass (Array Integer) + {[> ] + [_ ]}))