diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2014, Satoshi Egi +Copyright (c) 2011-2015, Satoshi Egi Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,6 +1,6 @@ Name: egison -Version: 3.5.6 -Synopsis: Programming language with non-linear pattern-matching against unfree data +Version: 3.5.7 +Synopsis: Programming language with non-linear pattern-matching against non-free data Description: An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language. We can directly represent pattern-matching against lists, multisets, sets, trees, graphs and any kind of data types. @@ -8,8 +8,8 @@ We can find Egison programs in @lib@ and @sample@ directories. This package also include Emacs Lisp file @elisp/egison-mode.el@. . - We can do non-linear pattern-matching against unfree data types in Egison. - An unfree data type is a data type whose data have no canonical form, a standard way to represent that object. + We can do non-linear pattern-matching against non-free data types in Egison. + An non-free data type is a data type whose data have no canonical form, a standard way to represent that object. It enables us to write elegant programs. . /Twin Primes/ @@ -68,7 +68,7 @@ location: https://github.com/egison/egison.git Library - Build-Depends: base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, strict-io, text, regex-posix + Build-Depends: base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process Hs-Source-Dirs: hs-src Exposed-Modules: Language.Egison @@ -97,7 +97,8 @@ Executable egison Main-is: egison.hs - Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, strict-io, text + Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, text, regex-tdfa, process Hs-Source-Dirs: hs-src/Interpreter Other-modules: Paths_egison + ghc-options: -rtsopts -threaded ghc-prof-options: -prof -auto-all diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -1,13 +1,40 @@ ;;; egison-mode.el --- Egison editing mode -;; Copyright 2011-2013 Satoshi Egi +;; Copyright (C) 2011-2015 Satoshi Egi +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the "Software"), +;; to deal in the Software without restriction, including without limitation +;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;; and/or sell copies of the Software, and to permit persons to whom the Software +;; is furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be included +;; in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, +;; INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR +;; A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF +;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE +;; OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + ;;; Author: Satoshi Egi ;;; URL: https://github.com/egisatoshi/egison3/blob/master/elisp/egison-mode.el ;;; Version: 0.1.5 -;; Code goes here +;;; Commentary: +;; Emacs Mode for Egison +;; +;; Please put it in your load-path of Emacs. Then, add the following +;; lines in your .emacs. +;; +;; (autoload 'egison-mode "egison-mode" "Major mode for editing Egison code." t) +;; (setq auto-mode-alist (cons `("\\.egi$" . egison-mode) auto-mode-alist)) + +;;; Code: + (defconst egison-font-lock-keywords-1 (eval-when-compile (list @@ -80,44 +107,44 @@ "Default expressions to highlight in Egison modes.") -(defun open-paren-p () +(defun egison-open-paren-p () (let ((c (string-to-char (thing-at-point 'char)))) (or (eq c 40) (eq c 60) (eq c 91) (eq c 123)))) -(defun close-paren-p () +(defun egison-close-paren-p () (let ((c (string-to-char (thing-at-point 'char)))) (or (eq c 41) (eq c 62) (eq c 93) (eq c 125)))) -(defun last-unclosed-paren () +(defun egison-last-unclosed-paren () (save-excursion (let ((pc 0)) (while (<= pc 0) (if (bobp) (setq pc 2) (backward-char) - (if (open-paren-p) + (if (egison-open-paren-p) (progn (setq pc (+ pc 1)) (if (and (= pc 0) (= (current-column) 0)) (setq pc 2))) - (if (close-paren-p) + (if (egison-close-paren-p) (setq pc (- pc 1)))))) (if (= pc 2) nil (point))))) -(defun indent-point () +(defun egison-indent-point () (save-excursion (beginning-of-line) - (let ((p (last-unclosed-paren))) + (let ((p (egison-last-unclosed-paren))) (if p (progn - (goto-char (last-unclosed-paren)) + (goto-char (egison-last-unclosed-paren)) (let ((cp (current-column))) (cond ((eq (string-to-char (thing-at-point 'char)) 40) (forward-char) (let* ((op (current-word)) - (ip (keyword-indent-point op))) + (ip (egison-keyword-indent-point op))) (if ip (+ ip cp) (progn (forward-sexp) @@ -134,7 +161,7 @@ (t (+ 1 cp))))) 0)))) -(defun keyword-indent-point (name) +(defun egison-keyword-indent-point (name) (cond ((equal "module" name) 2) ((equal "define" name) 2) ((equal "test" name) 2) @@ -174,7 +201,7 @@ (defun egison-indent-line () "indent current line as Egison code." (interactive) - (indent-line-to (indent-point))) + (indent-line-to (egison-indent-point))) (defvar egison-mode-map @@ -186,8 +213,8 @@ (defvar egison-mode-syntax-table (let ((egison-mode-syntax-table (make-syntax-table))) - (modify-syntax-entry ?< "(" egison-mode-syntax-table) - (modify-syntax-entry ?> ")" egison-mode-syntax-table) + (modify-syntax-entry ?< "(>" egison-mode-syntax-table) + (modify-syntax-entry ?> ")<" egison-mode-syntax-table) (modify-syntax-entry ?\; "<" egison-mode-syntax-table) (modify-syntax-entry ?\n ">" egison-mode-syntax-table) (modify-syntax-entry ?\? "w" egison-mode-syntax-table) @@ -197,7 +224,7 @@ ;; (copy-syntax-table lisp-mode-syntax-table) "Syntax table for Egison mode") -(defun egison-mode-variables () +(defun egison-mode-set-variables () (set-syntax-table egison-mode-syntax-table) (set (make-local-variable 'font-lock-defaults) '((egison-font-lock-keywords @@ -208,10 +235,12 @@ (set (make-local-variable 'comment-start) ";") (set (make-local-variable 'comment-end) "") (set (make-local-variable 'comment-start-skip) ";+ *") + (set (make-local-variable 'comment-add) 1) (set (make-local-variable 'comment-end-skip) nil) ) +;;;###autoload (defun egison-mode () "Major mode for editing Egison code. @@ -225,7 +254,7 @@ (use-local-map egison-mode-map) (setq major-mode 'egison-mode) (setq mode-name "Egison") - (egison-mode-variables) + (egison-mode-set-variables) (run-mode-hooks 'egison-mode-hook)) @@ -239,5 +268,7 @@ See `run-hooks'." :type 'hook :group 'egison) + +(provide 'egison-mode) ;;; egison-mode.el ends here diff --git a/hs-src/Interpreter/egison.hs b/hs-src/Interpreter/egison.hs --- a/hs-src/Interpreter/egison.hs +++ b/hs-src/Interpreter/egison.hs @@ -216,7 +216,7 @@ showBanner :: IO () showBanner = do - putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2014 Satoshi Egi" + putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2015 Satoshi Egi" putStrLn $ "http://www.egison.org" putStrLn $ "Welcome to Egison Interpreter!" -- putStrLn $ "** Information **" 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 @@ -33,7 +33,7 @@ , packStringValue ) where -import Prelude hiding (mapM) +import Prelude hiding (mapM, mappend) import Control.Arrow import Control.Applicative @@ -43,6 +43,7 @@ import Data.Sequence (Seq, ViewL(..), ViewR(..), (><)) import qualified Data.Sequence as Sq +import Data.Ratio import Data.Foldable (toList) import Data.Traversable (mapM) import Data.IORef @@ -142,9 +143,8 @@ evalExpr _ (CharExpr c) = return . Value $ Char c evalExpr _ (StringExpr s) = return $ Value $ toEgison s evalExpr _ (BoolExpr b) = return . Value $ Bool b -evalExpr _ (RationalExpr x) = return . Value $ Rational x -evalExpr _ (IntegerExpr i) = return . Value $ Integer i -evalExpr _ (FloatExpr d) = return . Value $ Float d +evalExpr _ (NumberExpr x y) = return . Value $ reduceFraction (Number x y) +evalExpr _ (FloatExpr x y) = return . Value $ Float x y evalExpr env (VarExpr name) = refVar env name >>= evalRef @@ -195,7 +195,7 @@ makeHashKey :: WHNFData -> EgisonM EgisonHashKey makeHashKey (Value val) = case val of - Integer i -> return (IntKey i) + Number _ _ -> fromEgison val >>= (return . IntKey) Char c -> return (CharKey c) String str -> return (StrKey str) _ -> throwError $ TypeMismatch "integer or string" $ Value val @@ -322,9 +322,9 @@ evalExpr env expr >>= arraySize where arraySize :: WHNFData -> EgisonM WHNFData - arraySize (Intermediate (IArray arr)) = return . Value . toEgison $ snd $ Array.bounds arr - arraySize (Value (Array arr)) = return . Value . toEgison $ snd $ Array.bounds arr - arraySize val = throwError $ TypeMismatch "array" val + arraySize (Intermediate (IArray arr)) = return . Value . toEgison $ (snd (Array.bounds arr)) % 1 + arraySize (Value (Array arr)) = return . Value . toEgison $ (snd (Array.bounds arr)) % 1 + arraySize val = throwError $ TypeMismatch "array" val evalExpr _ SomethingExpr = return $ Value Something evalExpr _ UndefinedExpr = return $ Value Undefined @@ -405,7 +405,7 @@ bindEnv :: Env -> String -> Integer -> EgisonM Env bindEnv env name i = do - ref <- newEvalutedObjectRef (Value . Integer $ i) + ref <- newEvalutedObjectRef (Value (Number (i,0) (1,0))) return $ extendEnv env [(name, ref)] refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData @@ -582,7 +582,7 @@ Just pattern -> do let env'' = extendEnvForNonLinearPatterns env' bindings loops' indices' <- mapM (evalExpr env'' >=> liftM fromInteger . fromWHNF) indices - let pattern' = IndexedPat pattern $ map IntegerExpr indices' + let pattern' = IndexedPat pattern $ map (\i -> NumberExpr (i,0) (1,0)) indices' case trees' of [] -> return $ msingleton $ MState env loops bindings ((MAtom pattern' target matcher):trees) _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern' target matcher):(MNode penv (MState env' loops' bindings' trees')):trees) @@ -624,7 +624,7 @@ LoopPat name (LoopRange start ends endPat) pat pat' -> do startNum <- evalExpr env' start >>= fromWHNF - startNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum - 1) + startNumRef <- newEvalutedObjectRef $ Value $ Number ((startNum - 1),0) (1,0) ends' <- evalExpr env' ends if isPrimitiveValue ends' then do @@ -640,7 +640,7 @@ [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern" LoopPatContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do startNum <- evalRef startNumRef >>= fromWHNF - nextNumRef <- newEvalutedObjectRef $ Value $ Integer (startNum + 1) + nextNumRef <- newEvalutedObjectRef $ Value $ Number ((startNum + 1),0) (1,0) ends <- evalRef endsRef b <- isEmptyCollection ends if b @@ -918,13 +918,13 @@ extractPrimitiveValue :: WHNFData -> Either EgisonError EgisonValue extractPrimitiveValue (Value val@(Char _)) = return val extractPrimitiveValue (Value val@(Bool _)) = return val -extractPrimitiveValue (Value val@(Integer _)) = return val -extractPrimitiveValue (Value val@(Float _)) = return val +extractPrimitiveValue (Value val@(Number _ _)) = return val +extractPrimitiveValue (Value val@(Float _ _)) = return val extractPrimitiveValue whnf = throwError $ TypeMismatch "primitive value" whnf isPrimitiveValue :: WHNFData -> Bool isPrimitiveValue (Value (Char _)) = True isPrimitiveValue (Value (Bool _)) = True -isPrimitiveValue (Value (Integer _)) = True -isPrimitiveValue (Value (Float _)) = True +isPrimitiveValue (Value (Number _ _)) = True +isPrimitiveValue (Value (Float _ _)) = True isPrimitiveValue _ = False diff --git a/hs-src/Language/Egison/Desugar.hs b/hs-src/Language/Egison/Desugar.hs --- a/hs-src/Language/Egison/Desugar.hs +++ b/hs-src/Language/Egison/Desugar.hs @@ -287,7 +287,8 @@ collectName (TuplePat patterns) = collectNames patterns collectName (InductivePat _ patterns) = collectNames patterns collectName (ApplyPat _ patterns) = collectNames patterns - collectName (LoopPat _ _ pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 + collectName (LoopPat _ (LoopRange _ _ endNumPat) pattern1 pattern2) = collectName endNumPat `S.union` collectName pattern1 `S.union` collectName pattern2 +-- collectName (LoopPat _ (LoopRange _ _ endNumPat) pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 collectName (LetPat _ pattern) = collectName pattern collectName (IndexedPat (PatVar name) _) = S.singleton name collectName (OrPat patterns) = collectNames patterns @@ -301,26 +302,25 @@ desugarPattern' (PredPat expr) = PredPat <$> desugar expr desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns +desugarPattern' (OrPat patterns) = OrPat <$> mapM desugarPattern' patterns +desugarPattern' (OrderedOrPat []) = return (NotPat WildCard) +desugarPattern' (OrderedOrPat (pattern:patterns)) = do + pattern' <- desugarPattern' pattern + pattern'' <- desugarPattern' (OrderedOrPat patterns) + return $ OrPat [pattern', AndPat [(NotPat pattern'), pattern'']] desugarPattern' (TuplePat patterns) = TuplePat <$> mapM desugarPattern' patterns -desugarPattern' (InductivePat name patterns) = - InductivePat name <$> mapM desugarPattern' patterns -desugarPattern' (IndexedPat pattern exprs) = - IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs -desugarPattern' (ApplyPat expr patterns) = - ApplyPat <$> desugar expr <*> mapM desugarPattern' patterns -desugarPattern' (LoopPat name range pattern1 pattern2) = - LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 -desugarPattern' (LetPat binds pattern) = do - LetPat <$> desugarBindings binds <*> desugarPattern' pattern -desugarPattern' (OrPat patterns) = - OrPat <$> mapM desugarPattern' patterns +desugarPattern' (InductivePat name patterns) = InductivePat name <$> mapM desugarPattern' patterns +desugarPattern' (IndexedPat pattern exprs) = IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs +desugarPattern' (ApplyPat expr patterns) = ApplyPat <$> desugar expr <*> mapM desugarPattern' patterns +desugarPattern' (LoopPat name range pattern1 pattern2) = LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 +desugarPattern' (LetPat binds pattern) = LetPat <$> desugarBindings binds <*> desugarPattern' pattern desugarPattern' pattern = return pattern desugarLoopRange :: LoopRange -> DesugarM LoopRange desugarLoopRange (LoopRange sExpr eExpr pattern) = do sExpr' <- desugar sExpr eExpr' <- desugar eExpr - pattern' <- desugarPattern pattern + pattern' <- desugarPattern' pattern return $ LoopRange sExpr' eExpr' pattern' desugarBinding :: BindingExpr -> DesugarM BindingExpr 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 @@ -44,7 +44,7 @@ import qualified Text.Parsec.Token as P import qualified Data.Text as T -import Text.Regex.Posix +import Text.Regex.TDFA import Language.Egison.Types import Language.Egison.Desugar @@ -431,12 +431,14 @@ <|> patVar <|> varPat <|> valuePat + <|> regexPat <|> predPat <|> notPat <|> tuplePat <|> inductivePat <|> contPat <|> parens (andPat + <|> orderedOrPat <|> orPat <|> applyPat <|> loopPat @@ -454,6 +456,9 @@ valuePat :: Parser EgisonPattern valuePat = reservedOp "," >> ValuePat <$> expr +regexPat :: Parser EgisonPattern +regexPat = reservedOp "~" >> RegexPat <$> expr + predPat :: Parser EgisonPattern predPat = reservedOp "?" >> PredPat <$> expr @@ -478,6 +483,9 @@ orPat :: Parser EgisonPattern orPat = reservedOp "|" >> OrPat <$> sepEndBy pattern whiteSpace +orderedOrPat :: Parser EgisonPattern +orderedOrPat = reservedOp "|*" >> OrderedOrPat <$> sepEndBy pattern whiteSpace + applyPat :: Parser EgisonPattern applyPat = ApplyPat <$> expr <*> sepEndBy pattern whiteSpace @@ -491,7 +499,7 @@ return (LoopRange s e ep)) <|> (do s <- expr ep <- option WildCard pattern - return (LoopRange s (ApplyExpr (VarExpr "from") (ApplyExpr (VarExpr "-") (TupleExpr [s, (IntegerExpr 1)]))) ep))) + return (LoopRange s (ApplyExpr (VarExpr "from") (ApplyExpr (VarExpr "-") (TupleExpr [s, (NumberExpr (1, 0) (1, 0))]))) ep))) -- Constants @@ -500,8 +508,7 @@ <|> stringExpr <|> boolExpr <|> try floatExpr - <|> try rationalExpr - <|> integerExpr + <|> try numberExpr <|> (keywordSomething *> pure SomethingExpr) <|> (keywordUndefined *> pure UndefinedExpr) "constant" @@ -516,18 +523,40 @@ boolExpr = BoolExpr <$> boolLiteral floatExpr :: Parser EgisonExpr -floatExpr = FloatExpr <$> floatLiteral +floatExpr = do + x <- floatLiteral + y <- return 0 + return $ FloatExpr x y -rationalExpr :: Parser EgisonExpr -rationalExpr = do - m <- integerLiteral - char '/' - n <- naturalLiteral - return $ RationalExpr (m % n) +numberExpr :: Parser EgisonExpr +numberExpr = do + (m,n) <- P.lexeme lexer $ try (do m <- gaussianIntegerLiteral + char '/' + n <- gaussianIntegerLiteral + return (m,n)) + <|> try (do m <- gaussianIntegerLiteral + return (m,(1,0))) + return $ NumberExpr m n -integerExpr :: Parser EgisonExpr -integerExpr = IntegerExpr <$> integerLiteral +gaussianIntegerLiteral :: Parser (Integer, Integer) +gaussianIntegerLiteral = do + (x,y) <- P.lexeme lexer $ try (do x <- integerLiteral' + y <- sign' <*> positiveIntegerLiteral + char 'i' + return (x,y)) + <|> try (do y <- integerLiteral' + char 'i' + return (0,y)) + <|> try (do x <- integerLiteral' + return (x,0)) + return (x,y) +integerLiteral' :: Parser Integer +integerLiteral' = sign <*> positiveIntegerLiteral + +positiveIntegerLiteral :: Parser Integer +positiveIntegerLiteral = read <$> many1 digit + -- -- Tokens -- @@ -592,6 +621,7 @@ , "_" , "&" , "|" + , "|*" , "^" , "," , "." @@ -646,6 +676,10 @@ sign = (char '-' >> return negate) <|> (char '+' >> return id) <|> return id + +sign' :: Num a => Parser (a -> a) +sign' = (char '-' >> return negate) + <|> (char '+' >> return id) naturalLiteral :: Parser Integer naturalLiteral = P.natural lexer 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 @@ -16,14 +16,18 @@ import Data.IORef import Data.Ratio +import Data.Foldable (toList) +import Text.Regex.TDFA import System.IO import System.Random +import System.Process import qualified Data.Sequence as Sq import Data.Char (ord, chr) import qualified Data.Text as T +import Data.Text (Text) import qualified Data.Text.IO as T {-- -- for 'egison-sqlite' @@ -93,7 +97,7 @@ -- constants :: [(String, EgisonValue)] -constants = [ ("pi", Float 3.141592653589793) ] +constants = [ ("pi", Float 3.141592653589793 0) ] -- -- Primitives @@ -106,12 +110,14 @@ , ("/", divide) , ("numerator", numerator') , ("denominator", denominator') + , ("real-part", realPart) + , ("imaginary-part", imaginaryPart) , ("modulo", integerBinaryOp mod) , ("quotient", integerBinaryOp quot) , ("remainder", integerBinaryOp rem) - , ("neg", integerUnaryOp negate) - , ("abs", integerUnaryOp abs) + , ("neg", rationalUnaryOp negate) + , ("abs", rationalUnaryOp abs) , ("eq?", eq) , ("lt?", lt) @@ -122,7 +128,7 @@ , ("round", floatToIntegerOp round) , ("floor", floatToIntegerOp floor) , ("ceiling", floatToIntegerOp ceiling) - , ("truncate", floatToIntegerOp truncate) + , ("truncate", truncate') , ("sqrt", floatUnaryOp sqrt) , ("exp", floatUnaryOp exp) @@ -151,6 +157,10 @@ , ("length-string", lengthString) , ("append-string", appendString) , ("split-string", splitString) + , ("regex", regexString) + , ("regex-cg", regexStringCaptureGroup) + + , ("read-process", readProcess') , ("read", read') , ("read-tsv", readTSV) @@ -164,10 +174,10 @@ , ("bool?", isBool) , ("integer?", isInteger) , ("rational?", isRational) + , ("number?", isNumber) , ("float?", isFloat) , ("char?", isChar) , ("string?", isString) - , ("tuple?", isTuple) , ("collection?", isCollection) , ("array?", isArray) , ("hash?", isHash) @@ -176,16 +186,30 @@ , ("assert-equal", assertEqual) ] -integerUnaryOp :: (Integer -> Integer) -> PrimitiveFunc -integerUnaryOp op = oneArg $ \val -> do - i <- fromEgison val - return $ Integer $ op i +rationalUnaryOp :: (Rational -> Rational) -> PrimitiveFunc +rationalUnaryOp op = oneArg $ \val -> do + r <- fromEgison val + let r' = op r + return $ Number ((numerator r'), 0) ((denominator r'), 0) +rationalBinaryOp :: (Rational -> Rational -> Rational) -> PrimitiveFunc +rationalBinaryOp op = twoArgs $ \val val' -> do + r <- fromEgison val :: EgisonM Rational + r' <- fromEgison val' :: EgisonM Rational + let r'' = (op r r'') + return $ Number ((numerator r''), 0) ((denominator r''), 0) + +rationalBinaryPred :: (Rational -> Rational -> Bool) -> PrimitiveFunc +rationalBinaryPred pred = twoArgs $ \val val' -> do + r <- fromEgison val + r' <- fromEgison val' + return $ Bool $ pred r r' + integerBinaryOp :: (Integer -> Integer -> Integer) -> PrimitiveFunc integerBinaryOp op = twoArgs $ \val val' -> do i <- fromEgison val i' <- fromEgison val' - return $ Integer $ op i i' + return $ Number ((op i i'), 0) (1, 0) integerBinaryPred :: (Integer -> Integer -> Bool) -> PrimitiveFunc integerBinaryPred pred = twoArgs $ \val val' -> do @@ -196,15 +220,16 @@ floatUnaryOp :: (Double -> Double) -> PrimitiveFunc floatUnaryOp op = oneArg $ \val -> do case val of - (Float f) -> return $ Float $ op f - (Integer i) -> return $ Float $ op (fromIntegral i) - (Rational r) -> return $ Float $ op (fromRational r) + (Float f 0) -> return $ Float (op f) 0 + n@(Number _ _) -> do + r <- fromEgison n + return $ Float (op (fromRational r)) 0 floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc floatBinaryOp op = twoArgs $ \val val' -> do f <- fromEgison val f' <- fromEgison val' - return $ Float $ op f f' + return $ Float (op f f') 0 floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc floatBinaryPred pred = twoArgs $ \val val' -> do @@ -218,92 +243,65 @@ plus :: PrimitiveFunc plus = twoArgs $ \val val' -> numberBinaryOp' val val' where - numberBinaryOp' (Integer i) (Integer i') = return $ Integer $ (+) i i' - numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val - numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1)) - numberBinaryOp' (Rational r) (Rational r') = let y = (+) r r' in - if denominator y == 1 - then return $ Integer $ numerator y - else return $ Rational y - numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f) - numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r)) - numberBinaryOp' (Float f) (Float f') = return $ Float $ (+) f f' - numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (addInteger' (mulInteger' x y') (mulInteger' x' y)) (mulInteger' y y') + numberBinaryOp' (Float x y) (Float x' y') = return $ Float (x + x') (y + y') + numberBinaryOp' (Number _ _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) minus :: PrimitiveFunc minus = twoArgs $ \val val' -> numberBinaryOp' val val' where - numberBinaryOp' (Integer i) (Integer i') = return $ Integer $ (-) i i' - numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val - numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1)) - numberBinaryOp' (Rational r) (Rational r') = let y = (-) r r' in - if denominator y == 1 - then return $ Integer $ numerator y - else return $ Rational y - numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f) - numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r)) - numberBinaryOp' (Float f) (Float f') = return $ Float $ (-) f f' - numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (subInteger' (mulInteger' x y') (mulInteger' x' y)) (mulInteger' y y') + numberBinaryOp' (Float x y) (Float x' y') = return $ Float (x - x') (y - y') + numberBinaryOp' (Number _ _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) multiply :: PrimitiveFunc multiply = twoArgs $ \val val' -> numberBinaryOp' val val' where - numberBinaryOp' (Integer i) (Integer i') = return $ Integer $ (*) i i' - numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val - numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1)) - numberBinaryOp' (Rational r) (Rational r') = let y = (*) r r' in - if denominator y == 1 - then return $ Integer $ numerator y - else return $ Rational y - numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f) - numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r)) - numberBinaryOp' (Float f) (Float f') = return $ Float $ (*) f f' - numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (mulInteger' x x') (mulInteger' y y') + numberBinaryOp' (Float x y) (Float x' y') = return $ Float (x * x' - y * y') (x * y' + x' * y) + numberBinaryOp' (Number _ _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) divide :: PrimitiveFunc divide = twoArgs $ \val val' -> numberBinaryOp' val val' where - numberBinaryOp' (Integer i) (Integer i') = numberBinaryOp' (Rational (i % 1)) (Rational (i' % 1)) - numberBinaryOp' (Integer i) val = numberBinaryOp' (Rational (i % 1)) val - numberBinaryOp' val (Integer i) = numberBinaryOp' val (Rational (i % 1)) - numberBinaryOp' (Rational r) (Rational r') = - let m = numerator r' in - let n = denominator r' in - let y = (r * (n % m)) in - if denominator y == 1 - then return $ Integer $ numerator y - else return $ Rational y - numberBinaryOp' (Rational r) (Float f) = numberBinaryOp' (Float (fromRational r)) (Float f) - numberBinaryOp' (Float f) (Rational r) = numberBinaryOp' (Float f) (Float (fromRational r)) - numberBinaryOp' (Float f) (Float f') = return $ Float $ (/) f f' - numberBinaryOp' (Rational _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryOp' (Float _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (mulInteger' x y') (mulInteger' y x') + numberBinaryOp' (Float f 0) (Float f' 0) = return $ Float (f / f') 0 + numberBinaryOp' (Number _ _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryOp' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) + numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) numerator' :: PrimitiveFunc numerator' = oneArg $ numerator'' where - numerator'' (Rational rat) = do - return $ Integer (numerator rat) - numerator'' (Integer x) = do - return $ Integer x + numerator'' (Number (x,y) _) = return (Number (x,y) (1,0)) numerator'' val = throwError $ TypeMismatch "rational" (Value val) denominator' :: PrimitiveFunc denominator' = oneArg $ denominator'' where - denominator'' (Rational rat) = do - return $ Integer (denominator rat) - denominator'' (Integer x) = do - return $ Integer 1 + denominator'' (Number _ (x,y)) = return (Number (x,y) (1,0)) denominator'' val = throwError $ TypeMismatch "rational" (Value val) +realPart :: PrimitiveFunc +realPart = oneArg $ realPart' + where + realPart' (Number (x,_) (x',0)) = return $ Number (x,0) (x',0) + realPart' (Number _ _) = throwError $ Default "real-part: denominator is not integer" + realPart' val = throwError $ TypeMismatch "number" (Value val) + +imaginaryPart :: PrimitiveFunc +imaginaryPart = oneArg $ imaginaryPart' + where + imaginaryPart' (Number (_,y) (x',0)) = return $ Number (y,0) (x',0) + imaginaryPart' (Number _ _) = throwError $ Default "imaginary-part: denominator is not integer" + imaginaryPart' val = throwError $ TypeMismatch "number" (Value val) + -- -- Pred -- @@ -314,90 +312,88 @@ lt :: PrimitiveFunc lt = twoArgs $ \val val' -> numberBinaryPred' val val' where - numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (<) i i' - numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val - numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1)) - numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (<) r r' - numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f) - numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r)) - numberBinaryPred' (Float f) (Float f') = return $ Bool $ (<) f f' - numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' m@(Number _ _) n@(Number _ _) = do + r <- fromEgison m :: EgisonM Rational + r' <- fromEgison n :: EgisonM Rational + return $ Bool $ (<) r r' + numberBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<) f f' + numberBinaryPred' (Number _ _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) lte :: PrimitiveFunc lte = twoArgs $ \val val' -> numberBinaryPred' val val' where - numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (<=) i i' - numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val - numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1)) - numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (<=) r r' - numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f) - numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r)) - numberBinaryPred' (Float f) (Float f') = return $ Bool $ (<=) f f' - numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' m@(Number _ _) n@(Number _ _) = do + r <- fromEgison m :: EgisonM Rational + r' <- fromEgison n :: EgisonM Rational + return $ Bool $ (<=) r r' + numberBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<=) f f' + numberBinaryPred' (Number _ _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) gt :: PrimitiveFunc gt = twoArgs $ \val val' -> numberBinaryPred' val val' where - numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (>) i i' - numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val - numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1)) - numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (>) r r' - numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f) - numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r)) - numberBinaryPred' (Float f) (Float f') = return $ Bool $ (>) f f' - numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' m@(Number _ _) n@(Number _ _) = do + r <- fromEgison m :: EgisonM Rational + r' <- fromEgison n :: EgisonM Rational + return $ Bool $ (>) r r' + numberBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>) f f' + numberBinaryPred' (Number _ _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) gte :: PrimitiveFunc gte = twoArgs $ \val val' -> numberBinaryPred' val val' where - numberBinaryPred' (Integer i) (Integer i') = return $ Bool $ (>=) i i' - numberBinaryPred' (Integer i) val = numberBinaryPred' (Rational (i % 1)) val - numberBinaryPred' val (Integer i) = numberBinaryPred' val (Rational (i % 1)) - numberBinaryPred' (Rational r) (Rational r') = return $ Bool $ (>=) r r' - numberBinaryPred' (Rational r) (Float f) = numberBinaryPred' (Float (fromRational r)) (Float f) - numberBinaryPred' (Float f) (Rational r) = numberBinaryPred' (Float f) (Float (fromRational r)) - numberBinaryPred' (Float f) (Float f') = return $ Bool $ (>=) f f' - numberBinaryPred' (Rational _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryPred' (Float _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' m@(Number _ _) n@(Number _ _) = do + r <- fromEgison m :: EgisonM Rational + r' <- fromEgison n :: EgisonM Rational + return $ Bool $ (>=) r r' + numberBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>=) f f' + numberBinaryPred' (Number _ _) val = throwError $ TypeMismatch "number" (Value val) + numberBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) +truncate' :: PrimitiveFunc +truncate' = oneArg $ \val -> numberUnaryOp' val + where + numberUnaryOp' (Number (x,0) (x',0)) = return $ Number ((quot x x'), 0) (1,0) + numberUnaryOp' (Float x y) = return $ Number ((truncate x), (truncate y)) (1,0) + numberUnaryOp' val = throwError $ TypeMismatch "ratinal or float" (Value val) + -- -- Transform -- integerToFloat :: PrimitiveFunc -integerToFloat = oneArg $ \val -> do - i <- fromEgison val - return $ Float $ fromInteger i +integerToFloat = rationalToFloat rationalToFloat :: PrimitiveFunc rationalToFloat = oneArg $ \val -> do case val of - Integer i -> return $ Float $ fromInteger i - Rational r -> return $ Float $ fromRational r + n@(Number (_,0) (_,0)) -> do + r <- fromEgison n + return $ Float (fromRational r) 0 _ -> throwError $ TypeMismatch "integer of rational number" (Value val) charToInteger :: PrimitiveFunc charToInteger = oneArg $ \val -> do case val of - Char c -> return $ Integer $ fromIntegral $ ord c + Char c -> return $ Number ((fromIntegral $ ord c), 0) (1,0) _ -> throwError $ TypeMismatch "character" (Value val) integerToChar :: PrimitiveFunc integerToChar = oneArg $ \val -> do case val of - Integer i -> return $ Char $ chr $ fromIntegral i - _ -> throwError $ TypeMismatch "character" (Value val) + (Number (x,0) (1,0)) -> return $ Char $ chr $ fromIntegral x + _ -> throwError $ TypeMismatch "integer" (Value val) floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc floatToIntegerOp op = oneArg $ \val -> do f <- fromEgison val - return $ Integer $ op f + return $ Number ((op f), 0) (1,0) -- -- String @@ -424,7 +420,7 @@ lengthString :: PrimitiveFunc lengthString = oneArg $ \val -> do case val of - String str -> return . Integer . toInteger $ T.length str + String str -> return . (\x -> Number (x,0) (1,0)) . toInteger $ T.length str _ -> throwError $ TypeMismatch "string" (Value val) appendString :: PrimitiveFunc @@ -441,6 +437,46 @@ (String _, _) -> throwError $ TypeMismatch "string" (Value src) (_, _) -> throwError $ TypeMismatch "string" (Value pat) +regexString :: PrimitiveFunc +regexString = twoArgs $ \pat src -> do + case (pat, src) of + (String patStr, String srcStr) -> do + let (a, b, c) = (((T.unpack srcStr) =~ (T.unpack patStr)) :: (String, String, String)) + if b == "" + then return . Collection . Sq.fromList $ [] + else return . Collection . Sq.fromList $ [Tuple [String $ T.pack a, String $ T.pack b, String $ T.pack c]] + (String _, _) -> throwError $ TypeMismatch "string" (Value src) + (_, _) -> throwError $ TypeMismatch "string" (Value pat) + +regexStringCaptureGroup :: PrimitiveFunc +regexStringCaptureGroup = twoArgs $ \pat src -> do + case (pat, src) of + (String patStr, String srcStr) -> do + let ret = (((T.unpack srcStr) =~ (T.unpack patStr)) :: [[String]]) + case ret of + [] -> return . Collection . Sq.fromList $ [] + ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr + return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]] + (String _, _) -> throwError $ TypeMismatch "string" (Value src) + (_, _) -> throwError $ TypeMismatch "string" (Value pat) + +--regexStringMatch :: PrimitiveFunc +--regexStringMatch = twoArgs $ \pat src -> do +-- case (pat, src) of +-- (String patStr, String srcStr) -> return . Bool $ (((T.unpack srcStr) =~ (T.unpack patStr)) :: Bool) +-- (String _, _) -> throwError $ TypeMismatch "string" (Value src) +-- (_, _) -> throwError $ TypeMismatch "string" (Value pat) + +readProcess' :: PrimitiveFunc +readProcess' = threeArgs $ \cmd args input -> do + case (cmd, args, input) of + (String cmdStr, Collection argStrs, String inputStr) -> do + outputStr <- liftIO $ readProcess (T.unpack cmdStr) (map (\arg -> case arg of + String argStr -> T.unpack argStr) + (toList argStrs)) (T.unpack inputStr) + return (String (T.pack outputStr)) + (_, _, _) -> throwError $ TypeMismatch "(string, collection, string)" (Value (Tuple [cmd, args, input])) + read' :: PrimitiveFunc read'= oneArg $ \val -> fromEgison val >>= readExpr . T.unpack >>= evalExprDeep nullEnv @@ -487,18 +523,25 @@ isBool _ = return $ Value $ Bool False isInteger :: PrimitiveFunc -isInteger (Value (Integer _)) = return $ Value $ Bool True +isInteger (Value (Number (_,0) (1,0))) = return $ Value $ Bool True isInteger _ = return $ Value $ Bool False isRational :: PrimitiveFunc -isRational (Value (Integer _)) = return $ Value $ Bool True -isRational (Value (Rational _)) = return $ Value $ Bool True +isRational (Value (Number (_, 0) (_, 0))) = return $ Value $ Bool True isRational _ = return $ Value $ Bool False +isNumber :: PrimitiveFunc +isNumber (Value (Number _ _)) = return $ Value $ Bool True +isNumber _ = return $ Value $ Bool False + isFloat :: PrimitiveFunc -isFloat (Value (Float _)) = return $ Value $ Bool True +isFloat (Value (Float _ 0)) = return $ Value $ Bool True isFloat _ = return $ Value $ Bool False +isComplex :: PrimitiveFunc +isComplex (Value (Float _ _)) = return $ Value $ Bool True +isComplex _ = return $ Value $ Bool False + isChar :: PrimitiveFunc isChar (Value (Char _)) = return $ Value $ Bool True isChar _ = return $ Value $ Bool False @@ -507,33 +550,6 @@ isString (Value (String _)) = return $ Value $ Bool True isString _ = return $ Value $ Bool False -isTuple :: PrimitiveFunc -isTuple args = do - args' <- fromTuple args - case args' of - ((Value (Integer n)):whnf:[]) -> isTuple' n whnf - (whnf:_) -> throwError $ TypeMismatch "number" whnf - where - fromTuple :: WHNFData -> EgisonM [WHNFData] - fromTuple (Intermediate (ITuple refs)) = do - objs <- liftIO $ mapM readIORef refs - mapM (\obj -> case obj of - Thunk thunk -> thunk - WHNF whnf -> return whnf) objs - fromTuple (Value (Tuple vals)) = return $ map Value vals - fromTuple whnf = return [whnf] - isTuple' :: Integer -> WHNFData -> EgisonM WHNFData - isTuple' n (Value (Tuple vals)) = - if n == ((fromIntegral (length vals)) :: Integer) - then return $ Value $ Bool True - else return $ Value $ Bool False - isTuple' n (Intermediate (ITuple refs)) = - if n == ((fromIntegral (length refs)) :: Integer) - then return $ Value $ Bool True - else return $ Value $ Bool False - isTuple' 1 _ = return $ Value $ Bool True - isTuple' _ _ = return $ Value $ Bool False - isCollection :: PrimitiveFunc isCollection (Value (Collection _)) = return $ Value $ Bool True isCollection (Intermediate (ICollection _)) = return $ Value $ Bool True @@ -669,7 +685,7 @@ readFile' :: PrimitiveFunc readFile' = oneArg $ \val -> do filename <- fromEgison val - s <- liftIO $ T.readFile filename + s <- liftIO $ T.readFile $ T.unpack filename return $ makeIO $ return $ toEgison s isEOFStdin :: PrimitiveFunc @@ -686,7 +702,7 @@ i <- fromEgison val i' <- fromEgison val' n <- liftIO $ getStdRandom $ randomR (i, i') - return $ makeIO $ return (Integer n) + return $ makeIO $ return $ Number (n,0) (1,0) {-- -- for 'egison-sqlite' sqlite :: PrimitiveFunc 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 @@ -28,6 +28,13 @@ , PrimitiveFunc (..) , EgisonData (..) , showTSV + , addInteger + , subInteger + , mulInteger + , addInteger' + , subInteger' + , mulInteger' + , reduceFraction -- * Internal data , Object (..) , ObjectRef (..) @@ -76,7 +83,7 @@ , mfor ) where -import Prelude hiding (foldr) +import Prelude hiding (foldr, mappend, mconcat) import Control.Exception import Data.Typeable @@ -124,9 +131,8 @@ CharExpr Char | StringExpr Text | BoolExpr Bool - | RationalExpr Rational - | IntegerExpr Integer - | FloatExpr Double + | NumberExpr (Integer, Integer) (Integer, Integer) + | FloatExpr Double Double | VarExpr String | IndexedExpr EgisonExpr [EgisonExpr] | InductiveDataExpr String [EgisonExpr] @@ -190,12 +196,14 @@ WildCard | PatVar String | ValuePat EgisonExpr + | RegexPat EgisonExpr | PredPat EgisonExpr | IndexedPat EgisonPattern [EgisonExpr] | LetPat [BindingExpr] EgisonPattern | NotPat EgisonPattern | AndPat [EgisonPattern] | OrPat [EgisonPattern] + | OrderedOrPat [EgisonPattern] | TuplePat [EgisonPattern] | InductivePat String [EgisonPattern] | LoopPat String LoopRange EgisonPattern EgisonPattern @@ -233,9 +241,8 @@ | Char Char | String Text | Bool Bool - | Rational Rational - | Integer Integer - | Float Double + | Number (Integer, Integer) (Integer, Integer) + | Float Double Double | InductiveData String [EgisonValue] | Tuple [EgisonValue] | Collection (Seq EgisonValue) @@ -263,9 +270,9 @@ show (String str) = "\"" ++ T.unpack str ++ "\"" show (Bool True) = "#t" show (Bool False) = "#f" - show (Rational x) = show (numerator x) ++ "/" ++ show (denominator x) - show (Integer i) = show i - show (Float f) = show f + show (Number (x,y) (1,0)) = showComplex x y + show (Number (x,y) (x',y')) = showComplex x y ++ "/" ++ showComplex x' y' + show (Float x y) = showComplex x y show (InductiveData name []) = "<" ++ name ++ ">" show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">" show (Tuple vals) = "[" ++ unwords (map show vals) ++ "]" @@ -289,6 +296,40 @@ show World = "#" show EOF = "#" +addInteger :: EgisonValue -> EgisonValue -> EgisonValue +addInteger (Number (x,y) (1,0)) (Number (x',y') (1,0)) = Number ((x+x'),(y+y')) (1,0) + +subInteger :: EgisonValue -> EgisonValue -> EgisonValue +subInteger (Number (x,y) (1,0)) (Number (x',y') (1,0)) = Number ((x-x'),(y-y')) (1,0) + +mulInteger :: EgisonValue -> EgisonValue -> EgisonValue +mulInteger (Number (x,y) (1,0)) (Number (x',y') (1,0)) = Number ((x*x'-y*y'),(x*y'+x'*y)) (1,0) + +addInteger' :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) +addInteger' (x,y) (x',y') = ((x+x'),(y+y')) + +subInteger' :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) +subInteger' (x,y) (x',y') = ((x-x'),(y-y')) + +mulInteger' :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer) +mulInteger' (x,y) (x',y') = ((x*x'-y*y'),(x*y'+x'*y)) + +showComplex :: (Num a, Eq a, Ord a, Show a) => a -> a -> String +showComplex x 0 = show x +showComplex 0 y = show y ++ "i" +showComplex x y = show x ++ (if y > 0 then "+" else "") ++ show y ++ "i" + +reduceFraction :: EgisonValue -> EgisonValue +reduceFraction (Number (x,y) (x',y')) + | x' < 0 = let m = negate (foldl gcd x [y, x', y']) in + Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m) + | x' > 0 = let m = foldl gcd x [y, x', y'] in + Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m) + | x' == 0 && y' < 0 = let m = negate (foldl gcd x [y, x', y']) in + Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m) + | x' == 0 && y' > 0 = let m = foldl gcd x [y, x', y'] in + Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m) + showTSV :: EgisonValue -> String showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map showTSV vals) showTSV (Collection vals) = intercalate "\t" (map showTSV (toList vals)) @@ -298,10 +339,9 @@ (Char c) == (Char c') = c == c' (String str) == (String str') = str == str' (Bool b) == (Bool b') = b == b' - (Integer i) == (Integer i') = i == i' - (Rational r) == (Rational r') = r == r' - (Float f) == (Float f') = f == f' - (InductiveData name vals) == (InductiveData name' vals') = name == name' && vals == vals' + (Number (x1,y1) (x1',y1')) == (Number (x2,y2) (x2',y2')) = (x1 == x2) && (y1 == y2) && (x1' == x2') && (y1' == y2') + (Float x y) == (Float x' y') = (x == x') && (y == y') + (InductiveData name vals) == (InductiveData name' vals') = (name == name') && (vals == vals') (Tuple vals) == (Tuple vals') = vals == vals' (Collection vals) == (Collection vals') = vals == vals' (Array vals) == (Array vals') = vals == vals' @@ -330,15 +370,15 @@ fromEgison = liftError . fromBoolValue instance EgisonData Integer where - toEgison i = Integer i + toEgison i = Number (i, 0) (1, 0) fromEgison = liftError . fromIntegerValue instance EgisonData Rational where - toEgison r = Rational r + toEgison r = Number ((numerator r), 0) ((denominator r), 0) fromEgison = liftError . fromRationalValue instance EgisonData Double where - toEgison f = Float f + toEgison f = Float f 0 fromEgison = liftError . fromFloatValue instance EgisonData Handle where @@ -392,15 +432,15 @@ fromBoolValue val = throwError $ TypeMismatch "bool" (Value val) fromIntegerValue :: EgisonValue -> Either EgisonError Integer -fromIntegerValue (Integer i) = return i +fromIntegerValue (Number (x, 0) (1, 0)) = return x fromIntegerValue val = throwError $ TypeMismatch "integer" (Value val) fromRationalValue :: EgisonValue -> Either EgisonError Rational -fromRationalValue (Rational x) = return x +fromRationalValue (Number (x, 0) (y, 0)) = return (x % y) fromRationalValue val = throwError $ TypeMismatch "rational" (Value val) fromFloatValue :: EgisonValue -> Either EgisonError Double -fromFloatValue (Float f) = return f +fromFloatValue (Float f 0) = return f fromFloatValue val = throwError $ TypeMismatch "float" (Value val) fromPortValue :: EgisonValue -> Either EgisonError Handle @@ -494,15 +534,15 @@ fromBoolWHNF whnf = throwError $ TypeMismatch "bool" whnf fromIntegerWHNF :: WHNFData -> Either EgisonError Integer -fromIntegerWHNF (Value (Integer i)) = return i +fromIntegerWHNF (Value (Number (x, 0) (1, 0))) = return x fromIntegerWHNF whnf = throwError $ TypeMismatch "integer" whnf fromRationalWHNF :: WHNFData -> Either EgisonError Rational -fromRationalWHNF (Value (Rational x)) = return x +fromRationalWHNF (Value (Number (x, 0) (y, 0))) = return (x % y) fromRationalWHNF whnf = throwError $ TypeMismatch "rational" whnf fromFloatWHNF :: WHNFData -> Either EgisonError Double -fromFloatWHNF (Value (Float f)) = return f +fromFloatWHNF (Value (Float f 0)) = return f fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf fromPortWHNF :: WHNFData -> Either EgisonError Handle diff --git a/hs-src/Language/Egison/Util.hs b/hs-src/Language/Egison/Util.hs --- a/hs-src/Language/Egison/Util.hs +++ b/hs-src/Language/Egison/Util.hs @@ -9,7 +9,7 @@ module Language.Egison.Util (getEgisonExpr, getEgisonExprOrNewLine, completeEgison) where import Data.List -import Text.Regex.Posix +import Text.Regex.TDFA import System.Console.Haskeline hiding (handle, catch, throwTo) import Control.Monad.Error (liftIO) @@ -91,7 +91,7 @@ egisonPrimitivesAfterOpenParen = map ((:) '(') $ ["+", "-", "*", "/", "numerator", "denominator", "modulo", "quotient", "remainder", "neg", "abs", "eq?", "lt?", "lte?", "gt?", "gte?", "round", "floor", "ceiling", "truncate", "sqrt", "exp", "log", "sin", "cos", "tan", "asin", "acos", "atan", "sinh", "cosh", "tanh", "asinh", "acosh", "atanh", "itof", "rtof", "stoi", "read", "show", "empty?", "uncons", "unsnoc", "assert", "assert-equal"] egisonKeywordsAfterOpenParen = map ((:) '(') $ ["define", "let", "letrec", "lambda", "match", "match-all", "match-lambda", "matcher", "algebraic-data-matcher", "pattern-function", "if", "loop", "io", "do"] - ++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "member?", "member?/m", "include?", "include?/m", "any", "all", "length", "count", "count/m", "car", "cdr", "rac", "rdc", "nth", "take", "drop", "while", "reverse", "multiset", "add", "add/m", "delete-first", "delete-first/m", "delete", "delete/m", "difference", "difference/m", "union", "union/m", "intersect", "intersect/m", "set", "unique", "unique/m", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "min", "max", "min-and-max", "power", "mod", "qsort", "intersperse", "intercalate", "split", "split/m"] + ++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "member?", "member?/m", "include?", "include?/m", "any", "all", "length", "count", "count/m", "car", "cdr", "rac", "rdc", "nth", "take", "drop", "while", "reverse", "multiset", "add", "add/m", "delete-first", "delete-first/m", "delete", "delete/m", "difference", "difference/m", "union", "union/m", "intersect", "intersect/m", "set", "unique", "unique/m", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "min", "max", "min-and-max", "power", "mod", "sort", "intersperse", "intercalate", "split", "split/m"] egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"] egisonKeywordsInNeutral = ["something"] ++ ["bool", "string", "integer", "nats", "primes"] diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -11,10 +11,7 @@ (lambda [$a] (matcher {[,$val [] - {[$tgt (match [val tgt] [(list a) (list a)] - {[[ ] {[]}] - [[ ] {[]}] - [[_ _] {}]})]}] + {[$tgt (if (eq? val tgt) {[]} {})]}] [ [] {[{} {[]}] [_ {}]}] @@ -36,45 +33,26 @@ {[$tgt {tgt}]}] }))) -(define $ordered-list +(define $sorted-list (lambda [$a] (matcher {[,$val [] - {[$tgt (match [val tgt] [(ordered-list a) (ordered-list a)] - {[[ ] {[]}] - [[ ] {[]}] - [[_ _] {}]})]}] + {[$tgt (if (eq? val tgt) {[]} {})]}] [ [] {[{} {[]}] [_ {}]}] - [> [(ordered-list a) (ordered-list a)] - {[{} {}] - [$tgt (match-all tgt (list a) - [(loop $i [1 $n] ) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n)) - rs]])]}] - [ [(ordered-list a) (ordered-list a)] + [> [(sorted-list a) (sorted-list a)] {[$tgt (match-all tgt (list a) - [(loop $i [1 $n] $rs) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n)) - rs]])]}] - [ [(ordered-list a)] - {[{$x @$xs} (if (gt? x px) - {} - {[xs]})] - [_ {}]}] - [ [a (ordered-list a)] - {[{$x @$xs} {[x xs]}] - [_ {}]}] - [ [(ordered-list a) (ordered-list a)] + [(loop $i [1 $n] ) + [(map (lambda [$i] (ref xa i)) (between 1 n)) + rs]])]}] + [ [(sorted-list a) (sorted-list a)] {[$tgt (match-all tgt (list a) - [(loop $i [1 $n] $rs) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n)) - rs]])]}] - [ [a (ordered-list a)] - {[{@$xs $x} (if (lt? x px) - {} - {[xs]})] - [_ {}]}] - [ [a (ordered-list a)] - {[{@$xs $x} {[x xs]}] + [(loop $i [1 $n] $rs) + [(map (lambda [$i] (ref xa i)) (between 1 n)) + rs]])]}] + [ [a (sorted-list a)] + {[{$x @$xs} {[x xs]}] [_ {}]}] [$ [something] {[$tgt {tgt}]}] @@ -122,6 +100,33 @@ {x @(while pred rs)} {})]}))) +(define $while-by + (lambda [$pred $xs] + (match xs (list something) + {[ {}] + [ + (if (pred x) + {x @(while-by pred rs)} + {x})]}))) + +(define $until + (lambda [$pred $xs] + (match xs (list something) + {[ {}] + [ + (if (not (pred x)) + {x @(until pred rs)} + {})]}))) + +(define $until-by + (lambda [$pred $xs] + (match xs (list something) + {[ {}] + [ + (if (not (pred x)) + {x @(until-by pred rs)} + {x})]}))) + ;; ;; cons, car, cdr ;; @@ -164,20 +169,26 @@ (define $map2 (lambda [$fn $xs $ys] (match [xs ys] [(list something) (list something)] - {[[ ] {}] + {[[ _] {}] + [[_ ] {}] [[ ] {(fn x y) @(map2 fn xs2 ys2)}]}))) -(define $zip - (lambda [$xs $ys] - (map2 (lambda [$x $y] [x y]) xs ys))) - (define $filter (lambda [$pred $xs] (foldr (lambda [$y $ys] (if (pred y) {y @ys} ys)) {} xs))) +(define $zip + (lambda [$xs $ys] + (map2 (lambda [$x $y] [x y]) xs ys))) + +(define $lookup + (lambda [$k $ls] + (match ls (list [something something]) + {[> x]}))) + ; Note. `foldr` is used in the definition of the list matcher. (define $foldr (lambda [$fn $init $ls] @@ -238,8 +249,11 @@ (define $find-cycle (lambda [$xs] - (match xs (list something) - {[>>> [s {x @c}]]}))) + (car (concat (match-all xs (list something) + [> + (match-all ys (list something) + [> + [hs {x @ms}]])]))))) (define $repeat (lambda [$xs] @@ -249,6 +263,14 @@ (lambda [$x] {x @(repeat1 x)})) +(define $merge + (lambda [$xs $ys] + (match [xs ys] [(list something) (list something)] + {[[ _] ys] + [[_ ] xs] + [[ ] {x @(merge txs ys)}] + [[_ ] {y @(merge xs tys)}]}))) + ;; ;; Others ;; @@ -348,15 +370,15 @@ (lambda [$x $xs] (match xs (list something) {[ {}] - [ (delete x rs)] - [ {y @(delete x rs)}]}))) + [> {@hs @(delete x ts)}] + [_ xs]}))) (define $delete/m (lambda [$a $x $xs] (match xs (list a) {[ {}] - [ (delete/m a x rs)] - [ {y @(delete/m a x rs)}]}))) + [> {@hs @(delete/m a x ts)}] + [_ xs]}))) (define $difference (lambda [$xs $ys] @@ -370,6 +392,24 @@ {[ xs] [ (difference/m a (delete-first/m a y xs) rs)]}))) +(define $include? + (lambda [$xs $ys] + (match ys (list something) + {[ #t] + [ + (if (member? y xs) + (include? (delete-first y xs) rs) + #f)]}))) + +(define $include?/m + (lambda [$a $xs $ys] + (match ys (list a) + {[ #t] + [ + (if (member?/m a y xs) + (include?/m a (delete-first y xs) rs) + #f)]}))) + (define $union (lambda [$xs $ys] {@xs @@ -444,7 +484,12 @@ (define $set (lambda [$a] (matcher - {[ [] + {[,$val [] + {[$tgt (match [val tgt] [(list a) (multiset a)] + {[[ ] {[]}] + [[ ] {[]}] + [[_ _] {}]})]}] + [ [] {[{} {[]}] [_ {}]}] [ [a (set a)] @@ -457,10 +502,11 @@ {tgt}] [_ {}]})]}] [ [(set a) (set a)] - {[$tgt (match-all tgt (multiset a) - [(loop $i [1 $n] _) - [(map (lambda [$i] x_i) (between 1 n)) tgt]])]}] - [$ [something] + {[$tgt (match-all tgt (list a) + [(loop $i [1 $n] > $ts) + [(map (lambda [$i] x_i) (between 1 n)) + tgt]])]}] + [$ [something] {[$tgt {tgt}]}] }))) @@ -469,24 +515,15 @@ ;; (define $unique (lambda [$xs] - (letrec {[$loop-fn - (lambda [$xs $ys] - (match xs (list something) - {[ ys] - [ - (if (member? x ys) - (loop-fn rs ys) - (loop-fn rs {@ys x}))]}))]} - (loop-fn xs {})))) + (match-all (sort xs) (list something) + [>> x]))) (define $unique/m (lambda [$a $xs] (letrec {[$loop-fn (lambda [$xs $ys] - (match xs (list something) - {[ ys] - [ - (if (member?/m a x ys) - (loop-fn rs ys) - (loop-fn rs {@ys x}))]}))]} + (match [xs ys] [(list a) (multiset a)] + {[[ _] ys] + [[ ] (loop-fn rs ys)] + [[ _] (loop-fn rs {@ys x})]}))]} (loop-fn xs {})))) diff --git a/lib/core/io.egi b/lib/core/io.egi --- a/lib/core/io.egi +++ b/lib/core/io.egi @@ -38,6 +38,16 @@ [(proc line)]} (each-line-from-port port proc)))))) +(define $each-file + (lambda [$files $proc] + (match files (list string) + {[ (return [])] + [ + (do {[$port (open-input-file file)] + [(each-line-from-port port proc)] + [(close-input-port port)]} + (each-file rest proc))]}))) + ;;; ;;; Collection ;;; diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -30,20 +30,15 @@ (define $evens {2 @(map (+ $ 2) evens)}) -(define $primes - (letrec {[$next-primes - (lambda [$primes1 $k] - (let {[$primes2 (while (lte? $ (floor (sqrt (itof (* 6 (+ k 1)))))) primes1)]} - (match [(any (lambda [$p] (eq? (remainder (+ (* 6 k) 1) p) 0)) primes2) - (any (lambda [$p] (eq? (remainder (+ (* 6 k) 5) p) 0)) primes2)] - [bool bool] - {[[,#f ,#f] {(+ (* 6 k) 1) (+ (* 6 k) 5) @(next-primes {@primes1 (+ (* 6 k) 1) (+ (* 6 k) 5)} (+ k 1))}] - [[,#f ,#t] {(+ (* 6 k) 1) @(next-primes {@primes1 (+ (* 6 k) 1)} (+ k 1))}] - [[,#t ,#f] {(+ (* 6 k) 5) @(next-primes {@primes1 (+ (* 6 k) 5)} (+ k 1))}] - [[,#t ,#t] (next-primes primes1 (+ k 1))] - })))]} - {2 3 5 @(next-primes {2 3 5} 1)})) +(define $fibs {1 1 @(map2 + fibs (cdr fibs))}) +(define $prime? + (lambda [$n] + (not (any 1#(eq? (remainder n %1) 0) + (while (lte? $ (floor (sqrt (itof n)))) primes))))) + +(define $primes {2 @(filter prime? (drop 2 nats))}) + (define $divisor? (lambda [$n $d] (eq? 0 (remainder n d)))) @@ -69,11 +64,10 @@ (lambda [$n] (eq? 1 (modulo n 2)))) -(define $prime? +(define $square? (lambda [$n] - (if (eq? n 1) - #f - (eq? (rac (while (lte? $ n) primes)) n)))) + (let {[$x (round (sqrt n))]} + (eq? n (power x 2))))) (define $gcd (lambda [$ns] @@ -173,3 +167,7 @@ {[[ ] (+ a (/ b (continued-fraction as bs)))] [[> ] a]})) + +(define $regular-continued-fraction-of-sqrt + (lambda [$n] + undefined)) diff --git a/lib/core/order.egi b/lib/core/order.egi --- a/lib/core/order.egi +++ b/lib/core/order.egi @@ -10,12 +10,23 @@ (define $compare (lambda [$m $n] - (if (lt? m n) + (if (collection? m) + (compare-c m n) + (if (lt? m n) (if (eq? m n) - - )))) + + ))))) +(define $compare-c + (lambda [$c1 $c2] + (match [c1 c2] [(list something) (list something)] + {[[ ] ] + [[ _] ] + [[_ ] ] + [[ ] (compare-c xs ys)] + [[ ] (compare x y)]}))) + (define $min (lambda [$ns] (foldl 2#(if (lt? %1 %2) %1 %2) (car ns) (cdr ns)))) @@ -65,9 +76,9 @@ [ [ys1 {x @ys2} ys3]] [ [ys1 ys2 {x @ys3}]]}))]}))) -(define $qsort (qsort/fn compare $)) +(define $sort (sort/fn compare $)) -(define $qsort/fn +(define $sort/fn (lambda [$f $xs] (match xs (list something) {[ {}] @@ -75,4 +86,4 @@ [_ (let* {[$n (length xs)] [$p (nth (quotient n 2) xs)] [[$ys1 $ys2 $ys3] (split-by-ordering/fn f p xs)]} - {@(qsort/fn f ys1) @ys2 @(qsort/fn f ys3)})]}))) + {@(sort/fn f ys1) @ys2 @(sort/fn f ys3)})]}))) diff --git a/lib/core/string.egi b/lib/core/string.egi --- a/lib/core/string.egi +++ b/lib/core/string.egi @@ -10,6 +10,10 @@ {[$tgt (if (eq? val tgt) {[]} {})]}] + [ [string (list string) string] + {[$tgt (regex-cg regexpr tgt)]}] + [ [string string string] + {[$tgt (regex regexpr tgt)]}] [ [] {[$tgt (if (eq? "" tgt) {[]} @@ -56,6 +60,11 @@ (match xs string {[ r]}))) +(define $S.rac + (lambda [$str] + (match str string + {[>> c]}))) + (define $S.map (lambda [$f $xs] (pack (map f (unpack xs))))) @@ -80,45 +89,40 @@ (define $S.intercalate (compose intersperse S.concat)) +(define $S.replace + (lambda [$before $after $str] + (S.intercalate after (S.split before str)))) + + ;; ;; Alphabet ;; +(define $C.between + (lambda [$c1 $c2] + (map itoc (between (ctoi c1) (ctoi c2))))) + +(define $C.between? + (lambda [$c1 $c2 $c] + (and (gte? (ctoi c) (ctoi c1)) + (lte? (ctoi c) (ctoi c2))))) + (define $alphabet? - (match-lambda char - {[,'a' #t] [,'b' #t] [,'c' #t] [,'d' #t] [,'e' #t] - [,'f' #t] [,'g' #t] [,'h' #t] [,'i' #t] [,'j' #t] - [,'k' #t] [,'l' #t] [,'m' #t] [,'n' #t] [,'o' #t] - [,'p' #t] [,'q' #t] [,'r' #t] [,'s' #t] [,'t' #t] - [,'u' #t] [,'v' #t] [,'w' #t] [,'x' #t] [,'y' #t] - [,'z' #t] - [,'A' #t] [,'B' #t] [,'C' #t] [,'D' #t] [,'E' #t] - [,'F' #t] [,'G' #t] [,'H' #t] [,'I' #t] [,'J' #t] - [,'K' #t] [,'L' #t] [,'M' #t] [,'N' #t] [,'O' #t] - [,'P' #t] [,'Q' #t] [,'R' #t] [,'S' #t] [,'T' #t] - [,'U' #t] [,'V' #t] [,'W' #t] [,'X' #t] [,'Y' #t] - [,'Z' #t] - [_ #f]})) + (lambda [$c] + (or (C.between? 'a' 'z' c) + (C.between? 'A' 'Z' c)))) (define $alphabets? (lambda [$s] (all alphabet? (unpack s)))) (define $upper-case - (match-lambda char - {[,'a' 'A'] [,'b' 'B'] [,'c' 'C'] [,'d' 'D'] [,'e' 'E'] - [,'f' 'F'] [,'g' 'G'] [,'h' 'H'] [,'i' 'I'] [,'j' 'J'] - [,'k' 'K'] [,'l' 'L'] [,'m' 'M'] [,'n' 'N'] [,'o' 'O'] - [,'p' 'P'] [,'q' 'Q'] [,'r' 'R'] [,'s' 'S'] [,'t' 'T'] - [,'u' 'U'] [,'v' 'V'] [,'w' 'W'] [,'x' 'X'] [,'y' 'Y'] - [,'z' 'Z'] - [$c c]})) + (lambda [$c] + (if (C.between? 'a' 'z' c) + (itoc (- (ctoi c) 32)) + c))) (define $lower-case - (match-lambda char - {[,'A' 'a'] [,'B' 'b'] [,'C' 'c'] [,'D' 'd'] [,'E' 'e'] - [,'F' 'f'] [,'G' 'g'] [,'H' 'h'] [,'I' 'i'] [,'J' 'j'] - [,'K' 'k'] [,'L' 'l'] [,'M' 'm'] [,'N' 'n'] [,'O' 'o'] - [,'P' 'p'] [,'Q' 'q'] [,'R' 'r'] [,'S' 's'] [,'T' 't'] - [,'U' 'u'] [,'V' 'v'] [,'W' 'w'] [,'X' 'x'] [,'Y' 'y'] - [,'Z' 'z'] - [$c c]})) + (lambda [$c] + (if (C.between? 'A' 'Z' c) + (itoc (+ (ctoi c) 32)) + c))) diff --git a/sample/io/cat.egi b/sample/io/cat.egi --- a/sample/io/cat.egi +++ b/sample/io/cat.egi @@ -2,14 +2,4 @@ (lambda [$args] (match args (list string) {[ (each-line print)] - [_ (each-file args)]}))) - -(define $each-file - (lambda [$files] - (match files (list string) - {[ (return [])] - [ - (do {[$port (open-input-file file)] - [(each-line-from-port port print)] - [(close-input-port port)]} - (each-file rest))]}))) + [_ (each-file args print)]})))