egison 3.5.6 → 3.5.7

raw patch · 16 files changed

+548/−376 lines, 16 filesdep +processdep +regex-tdfadep −regex-posixdep −strict-ioPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: process, regex-tdfa

Dependencies removed: regex-posix, strict-io

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• egison.cabal +7/−6
• elisp/egison-mode.el +48/−17
• hs-src/Interpreter/egison.hs +1/−1
• hs-src/Language/Egison/Core.hs +16/−16
• hs-src/Language/Egison/Desugar.hs +14/−14
• hs-src/Language/Egison/Parser.hs +47/−13
• hs-src/Language/Egison/Primitives.hs +169/−153
• hs-src/Language/Egison/Types.hs +63/−23
• hs-src/Language/Egison/Util.hs +2/−2
• lib/core/collection.egi +103/−66
• lib/core/io.egi +10/−0
• lib/core/number.egi +15/−17
• lib/core/order.egi +17/−6
• lib/core/string.egi +34/−30
• sample/io/cat.egi +1/−11

@@ -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"),

@@ -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

@@ -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 <egisatoshi@gmail.com> ;;; 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

@@ -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 **"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 = "#<world>"   show EOF = "#<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

@@ -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"]

@@ -11,10 +11,7 @@   (lambda [$a]     (matcher       {[,$val []-        {[$tgt (match [val tgt] [(list a) (list a)]-                 {[[<nil> <nil>] {[]}]-                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]-                  [[_ _] {}]})]}]+        {[$tgt (if (eq? val tgt) {[]} {})]}]        [<nil> []         {[{} {[]}]          [_ {}]}]@@ -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)]-                 {[[<nil> <nil>] {[]}]-                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]-                  [[_ _] {}]})]}]+        {[$tgt (if (eq? val tgt) {[]} {})]}]        [<nil> []         {[{} {[]}]          [_ {}]}]-       [<join $ <cons ,$px $>> [(ordered-list a) (ordered-list a)]-        {[{} {}]-         [$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <cons (& ?(lt? $ px) $xa_i) ...> <cons ,px $rs>) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n))-                                                                                    rs]])]}]-       [<join $ $> [(ordered-list a) (ordered-list a)]+       [<join $ <cons ,$px $>> [(sorted-list a) (sorted-list a)]         {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n))-                                                         rs]])]}]-       [<cons ,$px $> [(ordered-list a)]-        {[{$x @$xs} (if (gt? x px)-                      {}-                      {[xs]})]-         [_ {}]}]-       [<cons $ $> [a (ordered-list a)]-        {[{$x @$xs} {[x xs]}]-         [_ {}]}]-       [<nioj $ $> [(ordered-list a) (ordered-list a)]+                 [(loop $i [1 $n] <cons (& ?(lt? $ px) $xa_i) ...> <cons ,px $rs>)+                  [(map (lambda [$i] (ref xa i)) (between 1 n))+                   rs]])]}]+       [<join $ $> [(sorted-list a) (sorted-list a)]         {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n))-                                                         rs]])]}]-       [<snoc ,$px $> [a (ordered-list a)]-        {[{@$xs $x} (if (lt? x px)-                      {}-                      {[xs]})]-         [_ {}]}]-       [<snoc $ $> [a (ordered-list a)]-        {[{@$xs $x} {[x xs]}]+                 [(loop $i [1 $n] <cons $xa_i ...> $rs)+                  [(map (lambda [$i] (ref xa i)) (between 1 n))+                   rs]])]}]+       [<cons $ $> [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)+      {[<nil> {}]+       [<cons $x $rs>+        (if (pred x)+            {x @(while-by pred rs)}+            {x})]})))++(define $until+  (lambda [$pred $xs]+    (match xs (list something)+      {[<nil> {}]+       [<cons $x $rs>+        (if (not (pred x))+            {x @(until pred rs)}+            {})]})))++(define $until-by+  (lambda [$pred $xs]+    (match xs (list something)+      {[<nil> {}]+       [<cons $x $rs>+        (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)]-      {[[<nil> <nil>] {}]+      {[[<nil> _] {}]+       [[_ <nil>] {}]        [[<cons $x $xs2> <cons $y $ys2>]         {(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])+      {[<join _ <cons [,k $x] _>> 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)-      {[<join $s <cons $x <join $c <cons ,x _>>>> [s {x @c}]]})))+    (car (concat (match-all xs (list something)+                   [<join $ys <cons $x _>>+                    (match-all ys (list something)+                      [<join $hs <cons ,x $ms>>+                       [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)]+      {[[<nil> _] ys]+       [[_ <nil>] xs]+       [[<cons $x $txs> <cons ?(gte? $ x) _>] {x @(merge txs ys)}]+       [[_ <cons $y $tys>] {y @(merge xs tys)}]})))+ ;; ;; Others ;;@@ -348,15 +370,15 @@   (lambda [$x $xs]     (match xs (list something)       {[<nil> {}]-       [<cons ,x $rs> (delete x rs)]-       [<cons $y $rs> {y @(delete x rs)}]})))+       [<join $hs <cons ,x $ts>> {@hs @(delete x ts)}]+       [_ xs]})))  (define $delete/m   (lambda [$a $x $xs]     (match xs (list a)       {[<nil> {}]-       [<cons ,x $rs> (delete/m a x rs)]-       [<cons $y $rs> {y @(delete/m a x rs)}]})))+       [<join $hs <cons ,x $ts>> {@hs @(delete/m a x ts)}]+       [_ xs]})))  (define $difference   (lambda [$xs $ys]@@ -370,6 +392,24 @@       {[<nil> xs]        [<cons $y $rs> (difference/m a (delete-first/m a y xs) rs)]}))) +(define $include?+  (lambda [$xs $ys]+    (match ys (list something)+      {[<nil> #t]+       [<cons $y $rs>+        (if (member? y xs)+          (include? (delete-first y xs) rs)+          #f)]})))++(define $include?/m+  (lambda [$a $xs $ys]+    (match ys (list a)+      {[<nil> #t]+       [<cons $y $rs>+        (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-      {[<nil> []+      {[,$val []+        {[$tgt (match [val tgt] [(list a) (multiset a)]+                 {[[<nil> <nil>] {[]}]+                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]+                  [[_ _] {}]})]}]+       [<nil> []         {[{} {[]}]          [_ {}]}]        [<cons $ $> [a (set a)]@@ -457,10 +502,11 @@                    {tgt}]                   [_ {}]})]}]        [<join $ $> [(set a) (set a)]-        {[$tgt (match-all tgt (multiset a)-                 [(loop $i [1 $n] <cons $x_i ...> _)-                  [(map (lambda [$i] x_i) (between 1 n)) tgt]])]}]-       [$ [something]+       {[$tgt (match-all tgt (list a)+                 [(loop $i [1 $n] <join $rs_i <cons $x_i ...>> $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)-                  {[<nil> ys]-                   [<cons $x $rs>-                    (if (member? x ys)-                      (loop-fn rs ys)-                      (loop-fn rs {@ys x}))]}))]}-      (loop-fn xs {}))))+    (match-all (sort xs) (list something)+      [<join _ <cons $x ^<cons ,x _>>> x])))  (define $unique/m   (lambda [$a $xs]     (letrec {[$loop-fn               (lambda [$xs $ys]-                (match xs (list something)-                  {[<nil> ys]-                   [<cons $x $rs>-                    (if (member?/m a x ys)-                      (loop-fn rs ys)-                      (loop-fn rs {@ys x}))]}))]}+                (match [xs ys] [(list a) (multiset a)]+                  {[[<nil> _] ys]+                   [[<cons $x $rs> <cons ,x _>] (loop-fn rs ys)]+                   [[<cons $x $rs>  _] (loop-fn rs {@ys x})]}))]}       (loop-fn xs {}))))

@@ -38,6 +38,16 @@              [(proc line)]}           (each-line-from-port port proc)))))) +(define $each-file+  (lambda [$files $proc]+    (match files (list string)+      {[<nil> (return [])]+       [<cons $file $rest>+        (do {[$port (open-input-file file)]+             [(each-line-from-port port proc)]+             [(close-input-port port)]}+          (each-file rest proc))]})))+ ;;; ;;; Collection ;;;

@@ -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 @@     {[[<cons $a $as> <cons $b $bs>]       (+ a (/ b (continued-fraction as bs)))]      [[<cons $a <nil>> <nil>] a]}))++(define $regular-continued-fraction-of-sqrt+  (lambda [$n]+    undefined))

@@ -10,12 +10,23 @@  (define $compare   (lambda [$m $n]-    (if (lt? m n)+    (if (collection? m)+      (compare-c m n)+      (if (lt? m n)         <Less>         (if (eq? m n)-            <Equal>-            <Greater>))))+          <Equal>+          <Greater>))))) +(define $compare-c+  (lambda [$c1 $c2]+    (match [c1 c2] [(list something) (list something)]+      {[[<nil> <nil>] <Equal>]+       [[<nil> _] <Less>]+       [[_ <nil>] <Greater>]+       [[<cons $x $xs> <cons ,x $ys>] (compare-c xs ys)]+       [[<cons $x _> <cons $y _>] (compare x y)]})))+ (define $min   (lambda [$ns]     (foldl 2#(if (lt? %1 %2) %1 %2) (car ns) (cdr ns))))@@ -65,9 +76,9 @@              [<equal> [ys1 {x @ys2} ys3]]              [<greater> [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)       {[<nil> {}]@@ -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)})]})))

@@ -10,6 +10,10 @@       {[$tgt  (if (eq? val tgt)                 {[]}                 {})]}]+     [<regex-cg ,$regexpr $ $ $> [string (list string) string]+      {[$tgt (regex-cg regexpr tgt)]}]+     [<regex ,$regexpr $ $ $> [string string string]+      {[$tgt (regex regexpr tgt)]}]      [<nil> []       {[$tgt (if (eq? "" tgt)                {[]}@@ -56,6 +60,11 @@     (match xs string       {[<cons _ $r> r]}))) +(define $S.rac+  (lambda [$str]+    (match str string+      {[<join _ <cons $c <nil>>> 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)))

@@ -2,14 +2,4 @@   (lambda [$args]     (match args (list string)       {[<nil> (each-line print)]-       [_ (each-file args)]})))--(define $each-file-  (lambda [$files]-    (match files (list string)-      {[<nil> (return [])]-       [<cons $file $rest>-        (do {[$port (open-input-file file)]-             [(each-line-from-port port print)]-             [(close-input-port port)]}-          (each-file rest))]})))+       [_ (each-file args print)]})))