egison 3.10.1 → 3.10.2

raw patch · 33 files changed

+1716/−1994 lines, 33 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +6/−4
• hs-src/Language/Egison.hs +2/−4
• hs-src/Language/Egison/AST.hs +31/−86
• hs-src/Language/Egison/Core.hs +243/−318
• hs-src/Language/Egison/Desugar.hs +40/−49
• hs-src/Language/Egison/MathExpr.hs +295/−0
• hs-src/Language/Egison/MathOutput.hs +9/−8
• hs-src/Language/Egison/Parser.hs +6/−40
• hs-src/Language/Egison/ParserNonS.hs +178/−109
• hs-src/Language/Egison/Pretty.hs +27/−23
• hs-src/Language/Egison/Primitives.hs +146/−354
• hs-src/Language/Egison/Tensor.hs +440/−0
• hs-src/Language/Egison/Types.hs +42/−743
• hs-src/Language/Egison/Util.hs +12/−1
• hs-src/Tool/translator.hs +3/−11
• lib/core/io.egi +2/−2
• lib/core/sexpr.egi +3/−0
• lib/math/analysis/derivative.egi +7/−7
• lib/math/common/arithmetic.egi +5/−5
• lib/math/normalize.egi +34/−34
• nons-test/test/primitive.egi +1/−1
• nons-test/test/syntax.egi +71/−31
• sample/math/geometry/curvature-form.egi +8/−8
• sample/math/geometry/riemann-curvature-tensor-of-S2.egi +29/−27
• sample/math/geometry/riemann-curvature-tensor-of-T2.egi +32/−29
• sample/math/number/17th-root-of-unity.egi +4/−11
• sample/nishiwaki.egi +1/−1
• test/Test.hs +24/−44
• test/answer/sample/math/geometry/riemann-curvature-tensor-of-S2.egi +0/−23
• test/answer/sample/math/number/17th-root-of-unity.egi +0/−2
• test/lib/math/analysis.egi +11/−10
• test/lib/math/tensor.egi +4/−4
• test/syntax.egi +0/−5

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.10.1+Version:             3.10.2 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.@@ -63,7 +63,6 @@                      sample/*.egi sample/io/*.egi sample/math/algebra/*.egi sample/math/analysis/*.egi sample/math/geometry/*.egi sample/math/number/*.egi sample/math/others/*.egi                      test/*.egi test/lib/core/*.egi test/lib/math/*.egi                      nons-test/test/*.egi nons-test/test/lib/core/*.egi-                     test/answer/sample/math/geometry/*.egi test/answer/sample/math/number/*.egi                      elisp/egison-mode.el  @@ -105,14 +104,16 @@                    Language.Egison.CmdOptions                    Language.Egison.Desugar                    Language.Egison.Types+                   Language.Egison.Tensor                    Language.Egison.Parser                    Language.Egison.ParserNonS                    Language.Egison.Pretty                    Language.Egison.Primitives                    Language.Egison.Util+                   Language.Egison.MathExpr                    Language.Egison.MathOutput   Other-modules:   Paths_egison-  ghc-options:  -O3+  ghc-options:  -O3 -Wall -Wno-name-shadowing -Wno-incomplete-patterns  Test-Suite test   Type:           exitcode-stdio-1.0@@ -167,7 +168,7 @@     Build-Depends: semigroups   Hs-Source-Dirs:      hs-src/Interpreter   Other-modules:       Paths_egison-  ghc-options:  -O3 -threaded -eventlog -rtsopts+  ghc-options:  -O3 -threaded -eventlog -rtsopts -Wall -Wno-name-shadowing  Executable egison-translate   Main-is:          translator.hs@@ -177,3 +178,4 @@     , prettyprinter     , split   Hs-Source-Dirs:   hs-src/Tool+  ghc-options:  -Wall -Wno-name-shadowing

@@ -114,10 +114,8 @@ -- |Environment that contains core libraries initialEnv :: EgisonOpts -> IO Env initialEnv opts = do-  env <- if optNoIO opts then if optSExpr opts then primitiveEnvNoIO-                                               else primitiveEnvNoIO'-                         else if optSExpr opts then primitiveEnv-                                               else primitiveEnv'+  env <- if optNoIO opts then primitiveEnvNoIO+                         else primitiveEnv   ret <- evalEgisonTopExprs defaultOption env $ map Load coreLibraries   case ret of     Left err -> do

@@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}  {- |@@ -14,8 +16,11 @@   , EgisonExpr (..)   , EgisonPattern (..)   , Var (..)+  , VarWithIndices (..)+  , varToVarWithIndices   , Arg (..)   , Index (..)+  , extractIndex   , PMMode (..)   , InnerExpr (..)   , BindingExpr@@ -35,11 +40,11 @@ import           Data.List       (intercalate) import           Data.List.Split (splitOn) import           Data.Text       (Text)-import qualified Data.Text       as T import           GHC.Generics    (Generic)  data EgisonTopExpr =     Define Var EgisonExpr+  | DefineWithIndices VarWithIndices EgisonExpr   | Redefine Var EgisonExpr   | Test EgisonExpr   | Execute EgisonExpr@@ -69,12 +74,10 @@   | VectorExpr [EgisonExpr]    | LambdaExpr [Arg] EgisonExpr-  | LambdaArgExpr [Char]   | MemoizedLambdaExpr [String] EgisonExpr   | MemoizeExpr [(EgisonExpr, EgisonExpr, EgisonExpr)] EgisonExpr   | CambdaExpr String EgisonExpr   | ProcedureExpr [String] EgisonExpr-  | MacroExpr [String] EgisonExpr   | PatternFunctionExpr [String] EgisonPattern    | IfExpr EgisonExpr EgisonExpr EgisonExpr@@ -123,16 +126,19 @@    | SomethingExpr   | UndefinedExpr- deriving (Eq)+ deriving (Eq, Show)  data Var = Var [String] [Index ()]   deriving (Eq, Generic) +data VarWithIndices = VarWithIndices [String] [Index String]+ deriving (Eq)+ data Arg =     ScalarArg String   | InvertedScalarArg String   | TensorArg String- deriving (Eq)+ deriving (Eq, Show)  data Index a =     Subscript a@@ -142,10 +148,15 @@   | MultiSuperscript a a   | DFscript Integer Integer -- DifferentialForm   | Userscript a-  | DotSubscript a-  | DotSupscript a- deriving (Eq, Generic)+ deriving (Eq, Functor, Foldable, Generic, Traversable) +extractIndex :: Index a -> a+extractIndex (Subscript x)    = x+extractIndex (Superscript x)  = x+extractIndex (SupSubscript x) = x+extractIndex (Userscript x)   = x+extractIndex _                = error "extractIndex: Not supported"+ data InnerExpr =     ElementExpr EgisonExpr   | SubCollectionExpr EgisonExpr@@ -166,7 +177,6 @@   | PredPat EgisonExpr   | IndexedPat EgisonPattern [EgisonExpr]   | LetPat [BindingExpr] EgisonPattern-  | LaterPat EgisonPattern   | NotPat EgisonPattern   | AndPat [EgisonPattern]   | OrPat [EgisonPattern]@@ -185,10 +195,10 @@   | PlusPat [EgisonPattern]   | MultPat [EgisonPattern]   | PowerPat EgisonPattern EgisonPattern- deriving Eq+ deriving (Eq, Show)  data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern- deriving Eq+ deriving (Eq, Show)  data PrimitivePatPattern =     PPWildCard@@ -216,10 +226,7 @@                 , assoc    :: BinOpAssoc                 , isWedge  :: Bool    -- True if operator is prefixed with '!'                 }-  deriving (Eq, Ord)--instance Show EgisonBinOp where-  show = repr+  deriving (Eq, Ord, Show)  data BinOpAssoc   = LeftAssoc@@ -237,6 +244,7 @@   [ makeBinOp "^"  "**"        8 LeftAssoc   , makeBinOp "*"  "*"         7 LeftAssoc   , makeBinOp "/"  "/"         7 LeftAssoc+  , makeBinOp "."  "."         7 LeftAssoc -- tensor multiplication   , makeBinOp "%"  "remainder" 7 LeftAssoc   , makeBinOp "+"  "+"         6 LeftAssoc   , makeBinOp "-"  "-"         6 LeftAssoc@@ -263,42 +271,18 @@ stringToVarExpr :: String -> EgisonExpr stringToVarExpr = VarExpr . stringToVar -instance Show EgisonExpr where-  show (CharExpr c) = "c#" ++ [c]-  show (StringExpr str) = "\"" ++ T.unpack str ++ "\""-  show (BoolExpr True) = "#t"-  show (BoolExpr False) = "#f"-  show (IntegerExpr n) = show n-  show (FloatExpr x) = show x-  show (VarExpr name) = show name-  show (PartialVarExpr n) = "%" ++ show n-  show (FunctionExpr args) = "(function [" ++ unwords (map show args) ++ "])"-  show (IndexedExpr True expr idxs) = show expr ++ concatMap show idxs-  show (IndexedExpr False expr idxs) = show expr ++ "..." ++ concatMap show idxs-  show (TupleExpr exprs) = "[" ++ unwords (map show exprs) ++ "]"-  show (CollectionExpr ls) = "{" ++ unwords (map show ls) ++ "}"--  show (UnaryOpExpr op e) = op ++ " " ++ show e-  show (BinaryOpExpr op e1 e2) = "(" ++ show e1 ++ " " ++ show op ++ " " ++ show e2 ++ ")"--  show (QuoteExpr e) = "'" ++ show e-  show (QuoteSymbolExpr e) = "`" ++ show e--  show (ApplyExpr fn (TupleExpr [])) = "(" ++ show fn ++ ")"-  show (ApplyExpr fn (TupleExpr args)) = "(" ++ show fn ++ " " ++ unwords (map show args) ++ ")"-  show (ApplyExpr fn arg) = "(" ++ show fn ++ " " ++ show arg ++ ")"-  show (VectorExpr xs) = "[| " ++ unwords (map show xs) ++ " |]"-  show (WithSymbolsExpr xs e) = "(withSymbols {" ++ unwords (map show xs) ++ "} " ++ show e ++ ")"-  show _ = "(not supported)"- instance Show Var where   show (Var xs is) = intercalate "." xs ++ concatMap show is -instance Show Arg where-  show (ScalarArg name)         = "$" ++ name-  show (InvertedScalarArg name) = "*$" ++ name-  show (TensorArg name)         = "%" ++ name+instance Show VarWithIndices where+  show (VarWithIndices xs is) = intercalate "." xs ++ concatMap show is +varToVarWithIndices :: Var -> VarWithIndices+varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is+ where+   f :: Index () -> Index String+   f index = (\() -> "") <$> index+ instance Show (Index ()) where   show (Superscript ())  = "~"   show (Subscript ())    = "_"@@ -319,42 +303,3 @@   show (SupSubscript i) = "~_" ++ show i   show (DFscript _ _)   = ""   show (Userscript i)   = "|" ++ show i--instance Show EgisonPattern where-  show WildCard = "_"-  show (PatVar var) = "$" ++ show var-  show (ValuePat expr) = "," ++ show expr-  show (PredPat expr) = "?" ++ show expr-  show (IndexedPat pat exprs) = show pat ++ concatMap (("_" ++) . show) exprs-  show (LetPat bexprs pat) = "(let {" ++ unwords (map (\(vars, expr) -> "[" ++ showVarsHelper vars ++ " " ++ show expr ++ "]") bexprs) ++-                             "} " ++ show pat ++ ")"-    where showVarsHelper [] = ""-          showVarsHelper [v] = "$" ++ show v-          showVarsHelper vs = "[" ++ unwords (map (("$" ++) . show) vs) ++ "]"-  show (LaterPat pat) = "(later " ++ show pat ++ ")"-  show (NotPat pat) = "!" ++ show pat-  show (AndPat pats) = "(&" ++ concatMap ((" " ++) . show) pats ++ ")"-  show (OrPat pats) = "(|" ++ concatMap ((" " ++) . show) pats ++ ")"-  show (TuplePat pats) = "[" ++ unwords (map show pats) ++ "]"-  show (InductivePat name pats) = "<" ++ name ++ concatMap ((" " ++) . show) pats ++ ">"-  show (LoopPat var range pat endPat) = "(loop $" ++ unwords [show var, show range, show pat, show endPat] ++ ")"-  show ContPat = "..."-  show (PApplyPat expr pats) = "(" ++ unwords (show expr : map show pats) ++ ")"-  show (VarPat name) = name-  show SeqNilPat = "{}"-  show (SeqConsPat pat pat') = "{" ++ show pat ++ showSeqPatHelper pat' ++ "}"-    where showSeqPatHelper SeqNilPat = ""-          showSeqPatHelper (SeqConsPat pat pat') = " " ++ show pat ++ showSeqPatHelper pat'-          showSeqPatHelper pat = " " ++ show pat-  show LaterPatVar = "#"--  show (DApplyPat pat pats) = "(" ++ unwords (show pat : map show pats) ++ ")"-  show (DivPat pat pat') = "(/ " ++ show pat ++ " " ++ show pat' ++ ")"-  show (PlusPat pats) = "(+" ++ concatMap ((" " ++) . show) pats-  show (MultPat pats) = "(*" ++ concatMap ((" " ++) . show) pats-  show (PowerPat pat pat') = "(" ++ show pat ++ " ^ " ++ show pat' ++ ")"--instance Show LoopRange where-  show (LoopRange start (ApplyExpr (VarExpr (Var ["from"] [])) (ApplyExpr _ (TupleExpr (x:_)))) endPat) =-    "[" ++ show start ++ " (from " ++ show x ++ ") " ++ show endPat ++ "]"-  show (LoopRange start ends endPat) = "[" ++ show start ++ " " ++ show ends ++ " " ++ show endPat ++ "]"

@@ -14,7 +14,7 @@ module Language.Egison.Core     (     -- * Egison code evaluation-     collectDefs+      collectDefs     , evalTopExpr'     , evalExpr     , evalExprDeep@@ -36,19 +36,18 @@     -- * Tuple, Collection     , tupleToList     , collectionToList-    -- * Utiltiy functions-    , packStringValue     ) where  import           Prelude                     hiding (mapM, mappend, mconcat)  import           Control.Arrow import           Control.Monad               (when)-import           Control.Monad.Except        hiding (mapM)+import           Control.Monad.Except        (throwError) import           Control.Monad.State         hiding (mapM) import           Control.Monad.Trans.Maybe import           Control.Monad.Trans.State   (evalStateT, withStateT) +import           Data.Char                   (isUpper) import           Data.Foldable               (toList) import           Data.IORef import           Data.List                   (partition)@@ -61,15 +60,14 @@ import qualified Data.HashMap.Lazy           as HL import qualified Data.Vector                 as V -import           Data.Text                   (Text)-import qualified Data.Text                   as T- import           Language.Egison.AST import           Language.Egison.CmdOptions+import           Language.Egison.MathExpr import           Language.Egison.Parser      as Parser import           Language.Egison.ParserNonS  as ParserNonS import           Language.Egison.Pretty import           Language.Egison.Types+import           Language.Egison.Tensor  -- -- Evaluator@@ -79,6 +77,7 @@ collectDefs opts (expr:exprs) bindings rest =   case expr of     Define name expr -> collectDefs opts exprs ((name, expr) : bindings) rest+    DefineWithIndices{} -> throwError =<< EgisonBug "should not reach here (desugared)" <$> getFuncNameStack     Redefine _ _ -> collectDefs opts exprs bindings $ if optTestOnly opts then expr : rest else rest     Test _ -> collectDefs opts exprs bindings $ if optTestOnly opts then expr : rest else rest     Execute _ -> collectDefs opts exprs bindings $ if optTestOnly opts then rest else expr : rest@@ -98,6 +97,7 @@  evalTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EgisonM Env -> EgisonTopExpr -> EgisonM (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env) evalTopExpr' _ st (Define name expr) = return (Nothing, withStateT (\defines -> (name, expr):defines) st)+evalTopExpr' _ _ DefineWithIndices{} = throwError =<< EgisonBug "should not reach here (desugared)" <$> getFuncNameStack evalTopExpr' _ st (Redefine name expr) = return (Nothing, mapStateT (>>= \(env, defines) -> (, defines) <$> recursiveRebind env (name, expr)) st) evalTopExpr' opts st (Test expr) = do   pushFuncName "<stdin>"@@ -123,11 +123,11 @@   return (Nothing, withStateT (\defines -> bindings ++ defines) st)  evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData-evalExpr _ (CharExpr c) = return . Value $ Char c-evalExpr _ (StringExpr s) = return $ Value $ toEgison s-evalExpr _ (BoolExpr b) = return . Value $ Bool b+evalExpr _ (CharExpr c)    = return . Value $ Char c+evalExpr _ (StringExpr s)  = return . Value $ toEgison s+evalExpr _ (BoolExpr b)    = return . Value $ Bool b evalExpr _ (IntegerExpr x) = return . Value $ toEgison x-evalExpr _ (FloatExpr x) = return . Value $ Float x+evalExpr _ (FloatExpr x)   = return . Value $ Float x  evalExpr env (QuoteExpr expr) = do   whnf <- evalExpr env expr@@ -138,19 +138,19 @@ evalExpr env (QuoteSymbolExpr expr) = do   whnf <- evalExpr env expr   case whnf of-    Value val -> return . Value $ QuotedFunc val-    _         -> throwError =<< TypeMismatch "value in quote-function" whnf <$> getFuncNameStack+    Value fn@(Func (Just _) _ _ _) -> return . Value $ symbolScalarData "" (prettyS fn)+    Value (ScalarData _) -> return whnf+    _ -> throwError =<< TypeMismatch "value in quote-function" whnf <$> getFuncNameStack -evalExpr env (VarExpr name) = do-  x <- refVar' env name >>= evalRef-  return (case x of-            Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)) ->-              case fn of-                Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ prettyS name) argnames args js, 1)]]) p)-                Just s -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)-            _ -> x)+evalExpr env (VarExpr var@(Var [name@(c:_)] [])) | isUpper c = refVar' env var >>= evalRef  where   refVar' :: Env -> Var -> EgisonM ObjectRef+  refVar' env var = maybe (newEvaluatedObjectRef (Value (InductiveData name []))) return+                          (refVar env var)++evalExpr env (VarExpr name) = refVar' env name >>= evalRef+ where+  refVar' :: Env -> Var -> EgisonM ObjectRef   refVar' env var = maybe (newEvaluatedObjectRef (Value (symbolScalarData "" $ prettyS var))) return                           (refVar env var) @@ -184,7 +184,7 @@     let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList [toEgison $ toInteger i]) maybe_vwi      in evalExpr env' expr) $ zip exprs [1..(length exprs + 1)]   case whnfs of-    (Intermediate (ITensor Tensor{}):_) ->+    Intermediate (ITensor Tensor{}):_ ->       mapM toTensor (zipWith (curry f) whnfs [1..(length exprs + 1)]) >>= tConcat' >>= fromTensor     _ -> fromTensor (Tensor [fromIntegral $ length whnfs] (V.fromList whnfs) [])  where@@ -192,7 +192,7 @@     Intermediate $ ITensor $ Tensor ns (V.fromList $ zipWith (curry g) (V.toList xs) $ map (\ms -> map toEgison $ toInteger i:ms) $ enumTensorIndices ns) indices   f (x, _) = x   g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)), ms) =-    let fn' = maybe fn (\(VarWithIndices nameString indexList) -> Just $ symbolScalarData "" $ prettyS $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi+    let fn' = maybe fn (\(VarWithIndices nameString indexList) -> symbolScalarData' "" $ prettyS $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi      in Value $ ScalarData $ Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p   g (x, _) = x @@ -202,9 +202,9 @@   xsWhnf <- evalExpr env xsExpr   xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef   supWhnf <- evalExpr env supExpr-  sup <- fromCollection supWhnf >>= fromMList >>= mapM evalRefDeep -- >>= mapM extractScalar'+  sup <- fromCollection supWhnf >>= fromMList >>= mapM evalRefDeep   subWhnf <- evalExpr env subExpr-  sub <- fromCollection subWhnf >>= fromMList >>= mapM evalRefDeep -- >>= mapM extractScalar'+  sub <- fromCollection subWhnf >>= fromMList >>= mapM evalRefDeep   if product ns == toInteger (length xs)     then fromTensor (initTensor ns xs sup sub)     else throwError =<< InconsistentTensorSize <$> getFuncNameStack@@ -215,89 +215,57 @@   keys <- mapM makeHashKey keyWhnfs   refs <- mapM (newObjectRef env) exprs   case keys of-    [] -> do+    CharKey _ : _ -> do+      let keys' = map (\case CharKey c -> c) keys+      return . Intermediate . ICharHash $ HL.fromList $ zip keys' refs+    StrKey _ : _ -> do+      let keys' = map (\case StrKey s -> s) keys+      return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs+    _ -> do       let keys' = map (\case IntKey i -> i) keys       return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs-    _ ->-     case head keys of-       IntKey _ -> do-         let keys' = map (\ case IntKey i -> i) keys-         return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs-       CharKey _ -> do-         let keys' = map (\case CharKey c -> c) keys-         return . Intermediate . ICharHash $ HL.fromList $ zip keys' refs-       StrKey _ -> do-          let keys' = map (\case StrKey s -> s) keys-          return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs  where   makeHashKey :: WHNFData -> EgisonM EgisonHashKey   makeHashKey (Value val) =     case val of       ScalarData _ -> IntKey <$> fromEgison val-      Char c -> return (CharKey c)-      String str -> return (StrKey str)+      Char c       -> return (CharKey c)+      String str   -> return (StrKey str)       _ -> throwError =<< TypeMismatch "integer or string" (Value val) <$> getFuncNameStack   makeHashKey whnf = throwError =<< TypeMismatch "integer or string" whnf <$> getFuncNameStack  evalExpr env (IndexedExpr bool expr indices) = do   tensor <- case expr of               VarExpr (Var xs is) -> do-                let mObjRef = refVar env (Var xs $ is ++ map f indices)+                let mObjRef = refVar env (Var xs $ is ++ map (const () <$>) indices)                 case mObjRef of-                  (Just objRef) -> evalRef objRef-                  Nothing       -> evalExpr env expr+                  Just objRef -> evalRef objRef+                  Nothing     -> evalExpr env expr               _ -> evalExpr env expr   js <- mapM evalIndex indices   ret <- case tensor of-      (Value (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []])))) -> do+      Value (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []]))) -> do         js2 <- mapM evalIndexToScalar indices         return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js2, 1)]]) (Plus [Term 1 []])))-      (Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js', 1)]]) (Plus [Term 1 []])))) -> do+      Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js', 1)]]) (Plus [Term 1 []]))) -> do         js2 <- mapM evalIndexToScalar indices         return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (js' ++ js2), 1)]]) (Plus [Term 1 []])))-      (Value (TensorData (Tensor ns xs is))) ->+      Value (TensorData (Tensor ns xs is)) ->         if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)                 else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor)-      (Intermediate (ITensor (Tensor ns xs is))) ->+      Intermediate (ITensor (Tensor ns xs is)) ->         if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor                 else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor       _ -> do         js2 <- mapM evalIndexToScalar indices-        refArray tensor (map (\case-                                 Superscript k  -> ScalarData k-                                 Subscript k    -> ScalarData k-                                 SupSubscript k -> ScalarData k-                                 Userscript k   -> ScalarData k-                              ) js2)-  let ret2 = case expr of-               (VarExpr var) ->-                 case ret of-                   Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)) ->-                     case fn of-                       Nothing -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ prettyS var ++ concatMap show indices) argnames args js, 1)]]) p)-                       Just s -> Value $ ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)-                   _ -> ret-               _ -> ret-  return ret2+        refArray tensor (map (ScalarData . extractIndex) js2)+  return ret -- TODO: refactor  where   evalIndex :: Index EgisonExpr -> EgisonM (Index EgisonValue)-  evalIndex = \case-    Superscript n  -> Superscript  <$> evalExprDeep env n-    Subscript n    -> Subscript    <$> evalExprDeep env n-    SupSubscript n -> SupSubscript <$> evalExprDeep env n-    Userscript n   -> Userscript   <$> evalExprDeep env n-  evalIndexToScalar :: Index EgisonExpr -> EgisonM (Index ScalarData)-  evalIndexToScalar = \case-    Superscript n  -> Superscript  <$> (evalExprDeep env n >>= extractScalar)-    Subscript n    -> Subscript    <$> (evalExprDeep env n >>= extractScalar)-    SupSubscript n -> SupSubscript <$> (evalExprDeep env n >>= extractScalar)-    Userscript n   -> Userscript   <$> (evalExprDeep env n >>= extractScalar)+  evalIndex index = traverse (evalExprDeep env) index -  f :: Index a -> Index ()-  f (Superscript _)  = Superscript ()-  f (Subscript _)    = Subscript ()-  f (SupSubscript _) = SupSubscript ()-  f (Userscript _)   = Userscript ()+  evalIndexToScalar :: Index EgisonExpr -> EgisonM (Index ScalarData)+  evalIndexToScalar index = traverse ((extractScalar =<<) . evalExprDeep env) index  evalExpr env (SubrefsExpr bool expr jsExpr) = do   js <- map Subscript <$> (evalExpr env jsExpr >>= collectionToList)@@ -305,16 +273,16 @@               VarExpr (Var xs is) -> do                 let mObjRef = refVar env (Var xs $ is ++ replicate (length js) (Subscript ()))                 case mObjRef of-                  (Just objRef) -> evalRef objRef-                  Nothing       -> evalExpr env expr+                  Just objRef -> evalRef objRef+                  Nothing     -> evalExpr env expr               _ -> evalExpr env expr   case tensor of-    (Value (ScalarData _)) ->+    Value (ScalarData _) ->       return tensor-    (Value (TensorData (Tensor ns xs is))) ->+    Value (TensorData (Tensor ns xs is)) ->       if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)               else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor)-    (Intermediate (ITensor (Tensor ns xs is))) ->+    Intermediate (ITensor (Tensor ns xs is)) ->       if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor               else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor     _ -> throwError =<< NotImplemented "subrefs" <$> getFuncNameStack@@ -325,32 +293,34 @@               VarExpr (Var xs is) -> do                 let mObjRef = refVar env (Var xs $ is ++ replicate (length js) (Superscript ()))                 case mObjRef of-                  (Just objRef) -> evalRef objRef-                  Nothing       -> evalExpr env expr+                  Just objRef -> evalRef objRef+                  Nothing     -> evalExpr env expr               _ -> evalExpr env expr   case tensor of-    (Value (ScalarData _)) ->+    Value (ScalarData _) ->       return tensor-    (Value (TensorData (Tensor ns xs is))) ->+    Value (TensorData (Tensor ns xs is)) ->       if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)               else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor)-    (Intermediate (ITensor (Tensor ns xs is))) ->+    Intermediate (ITensor (Tensor ns xs is)) ->       if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor               else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor     _ -> throwError =<< NotImplemented "suprefs" <$> getFuncNameStack -evalExpr env (UserrefsExpr bool expr jsExpr) = do+evalExpr env (UserrefsExpr _ expr jsExpr) = do   val <- evalExprDeep env expr   js <- map Userscript <$> (evalExpr env jsExpr >>= collectionToList >>= mapM extractScalar)   case val of-    (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ js), 1)]]) (Plus [Term 1 []])))-    (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args is, 1)]]) (Plus [Term 1 []]))) -> return $ Value (ScalarData (Div (Plus [Term 1 [(FunctionData (Just name) argnames args (is ++ js), 1)]]) (Plus [Term 1 []])))+    ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])) ->+      return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ js), 1)]]) (Plus [Term 1 []])))+    ScalarData (Div (Plus [Term 1 [(FunctionData name argnames args is, 1)]]) (Plus [Term 1 []])) ->+      return $ Value (ScalarData (Div (Plus [Term 1 [(FunctionData name argnames args (is ++ js), 1)]]) (Plus [Term 1 []])))     _ -> throwError =<< NotImplemented "user-refs" <$> getFuncNameStack  evalExpr env (LambdaExpr names expr) = do   names' <- mapM (\case-                     (TensorArg name') -> return name'-                     (ScalarArg _) -> throwError =<< EgisonBug "scalar-arg remained" <$> getFuncNameStack) names+                     TensorArg name' -> return name'+                     ScalarArg _ -> throwError =<< EgisonBug "scalar-arg remained" <$> getFuncNameStack) names   return . Value $ Func Nothing env names' expr  evalExpr env (PartialExpr n expr) = return . Value $ PartialFunc env n expr@@ -359,15 +329,13 @@  evalExpr env (ProcedureExpr names expr) = return . Value $ Proc Nothing env names expr -evalExpr env (MacroExpr names expr) = return . Value $ Macro names expr- evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern -evalExpr (Env frame Nothing) (FunctionExpr args) = throwError $ Default "function symbol is not bound to a variable"+evalExpr (Env _ Nothing) (FunctionExpr _) = throwError $ Default "function symbol is not bound to a variable" -evalExpr env@(Env frame (Just name)) (FunctionExpr args) = do-  args' <- mapM (evalExprDeep env) args-  return . Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (Just $ symbolScalarData "" $ prettyS name) (map (symbolScalarData "" . prettyS) args) args' [], 1)]]) (Plus [Term 1 []]))+evalExpr env@(Env _ (Just name)) (FunctionExpr args) = do+  args' <- mapM (evalExprDeep env) args >>= mapM extractScalar+  return . Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (symbolScalarData' "" (prettyS name)) (map (symbolScalarData' "" . prettyS) args) args' [], 1)]]) (Plus [Term 1 []]))  evalExpr env (IfExpr test expr expr') = do   test <- evalExpr env test >>= fromWHNF@@ -379,7 +347,9 @@   extractBindings :: BindingExpr -> EgisonM [Binding]   extractBindings ([name], expr) =     case expr of-      FunctionExpr args -> let Env frame _ = env in makeBindings [name] . (:[]) <$> newObjectRef (Env frame (Just $ varToVarWithIndices name)) expr+      FunctionExpr _ ->+        let Env frame _ = env+         in makeBindings [name] . (:[]) <$> newObjectRef (Env frame (Just $ varToVarWithIndices name)) expr       _ -> makeBindings [name] . (:[]) <$> newObjectRef env expr   extractBindings (names, expr) =     makeBindings names <$> (evalExpr env expr >>= fromTuple)@@ -408,24 +378,16 @@   syms <- evalExpr env vars >>= collectionToList   whnf <- evalExpr env expr   case whnf of-    (Intermediate (ITensor t)) -> do-      t' <- tTranspose' syms t-      return (Intermediate (ITensor t'))-    (Value (TensorData t)) -> do-      t' <- tTranspose' syms t-      return (Value (TensorData t'))-    _ -> return whnf+    Intermediate (ITensor t) -> Intermediate . ITensor <$> tTranspose' syms t+    Value (TensorData t)     -> Value . TensorData <$> tTranspose' syms t+    _                        -> return whnf  evalExpr env (FlipIndicesExpr expr) = do   whnf <- evalExpr env expr   case whnf of-    (Intermediate (ITensor t)) -> do-      t' <- tFlipIndices t-      return (Intermediate (ITensor t'))-    (Value (TensorData t)) -> do-      t' <- tFlipIndices t-      return (Value (TensorData t'))-    _ -> return whnf+    Intermediate (ITensor t) -> Intermediate . ITensor <$> tFlipIndices t+    Value (TensorData t)     -> Value . TensorData <$> tFlipIndices t+    _                        -> return whnf  evalExpr env (WithSymbolsExpr vars expr) = do   symId <- fresh@@ -433,27 +395,22 @@   let bindings = zip (map stringToVar vars) syms   whnf <- evalExpr (extendEnv env bindings) expr   case whnf of-    (Value (TensorData (Tensor ns xs js))) ->-      removeTmpscripts symId (Value (TensorData (Tensor ns xs js)))-    (Intermediate (ITensor (Tensor ns xs js))) ->-      removeTmpscripts symId (Intermediate (ITensor (Tensor ns xs js)))+    Value (TensorData t@Tensor{}) ->+      Value . TensorData <$> removeTmpScripts symId t+    Intermediate (ITensor t@Tensor{}) ->+      Intermediate . ITensor <$> removeTmpScripts symId t     _ -> return whnf  where   isTmpSymbol :: String -> Index EgisonValue -> Bool-  isTmpSymbol symId (Subscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))) = symId == id-  isTmpSymbol symId (Superscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))) = symId == id-  isTmpSymbol symId (SupSubscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))) = symId == id-  isTmpSymbol symId (Userscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))) = symId == id-  removeTmpscripts :: String -> WHNFData -> EgisonM WHNFData-  removeTmpscripts symId (Intermediate (ITensor (Tensor s xs is))) = do-    let (ds, js) = partition (isTmpSymbol symId) is-    (Tensor s ys _) <- tTranspose (js ++ ds) (Tensor s xs is)-    return (Intermediate (ITensor (Tensor s ys js)))-  removeTmpscripts symId (Value (TensorData (Tensor s xs is))) = do+  isTmpSymbol symId (Subscript    (ScalarData (Div (Plus [Term 1 [(Symbol id _ _, _)]]) (Plus [Term 1 []])))) = symId == id+  isTmpSymbol symId (Superscript  (ScalarData (Div (Plus [Term 1 [(Symbol id _ _, _)]]) (Plus [Term 1 []])))) = symId == id+  isTmpSymbol symId (SupSubscript (ScalarData (Div (Plus [Term 1 [(Symbol id _ _, _)]]) (Plus [Term 1 []])))) = symId == id+  isTmpSymbol symId (Userscript   (ScalarData (Div (Plus [Term 1 [(Symbol id _ _, _)]]) (Plus [Term 1 []])))) = symId == id+  removeTmpScripts :: HasTensor a => String -> Tensor a -> EgisonM (Tensor a)+  removeTmpScripts symId (Tensor s xs is) = do     let (ds, js) = partition (isTmpSymbol symId) is-    (Tensor s ys _) <- tTranspose (js ++ ds) (Tensor s xs is)-    return (Value (TensorData (Tensor s ys js)))-  removeDFscripts _ = return+    Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is)+    return (Tensor s ys js)   evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do@@ -488,7 +445,7 @@   f matcher target = do       let tryMatchClause (pattern, expr) results = do             result <- patternMatch pmmode env pattern target matcher-            mmap (flip evalExpr expr . extendEnv env) result >>= flip mappend results+            mmap (flip evalExpr expr . extendEnv env) result >>= (`mappend` results)       mfoldr tryMatchClause (return MNil) (fromList clauses)  evalExpr env (MatchExpr pmmode target matcher clauses) = do@@ -507,7 +464,7 @@       foldr tryMatchClause (throwError $ MatchFailure currentFuncName callstack) clauses  evalExpr env (SeqExpr expr1 expr2) = do-  evalExprDeep env expr1+  _ <- evalExprDeep env expr1   evalExpr env expr2  evalExpr env (CApplyExpr func arg) = do@@ -531,13 +488,21 @@  evalExpr env (ApplyExpr func arg) = do   func <- evalExpr env func >>= appendDFscripts 0-  arg <- evalExpr env arg   case func of-    Value (TensorData t@(Tensor ns fs js)) ->+--    Value (ScalarData (Div (Plus [Term 1 [(Symbol "" name@(c:_) [], 1)]]) (Plus [Term 1 []]))) | isUpper c ->+    Value (InductiveData name []) ->+      case arg of+        TupleExpr exprs ->+          Intermediate . IInductiveData name <$> mapM (newObjectRef env) exprs+        _ -> throwError $ Default "argument is not a tuple"+    Value (TensorData t@Tensor{}) -> do+      arg <- evalExpr env arg       Value <$> (tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor) >>= removeDFscripts-    Intermediate (ITensor t@(Tensor ns fs js)) ->+    Intermediate (ITensor t@Tensor{}) -> do+      arg <- evalExpr env arg       tMap (\f -> applyFunc env f arg) t >>= fromTensor-    Value (MemoizedFunc name ref hashRef env names body) -> do+    Value (MemoizedFunc name ref hashRef env' names body) -> do+      arg <- evalExpr env arg       indices <- evalWHNF arg       indices' <- mapM fromEgison $ fromTupleValue indices       hash <- liftIO $ readIORef hashRef@@ -545,13 +510,15 @@         Just objRef ->           evalRef objRef         Nothing -> do-          whnf <- applyFunc env (Value (Func Nothing env names body)) arg+          whnf <- applyFunc env' (Value (Func Nothing env' names body)) arg           retRef <- newEvaluatedObjectRef whnf           hash <- liftIO $ readIORef hashRef           liftIO $ writeIORef hashRef (HL.insert indices' retRef hash)-          writeObjectRef ref (Value (MemoizedFunc name ref hashRef env names body))+          writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body))           return whnf-    _ -> applyFunc env func arg >>= removeDFscripts+    _ -> do+      arg <- evalExpr env arg+      applyFunc env func arg >>= removeDFscripts  evalExpr env (WedgeApplyExpr func arg) = do   func <- evalExpr env func >>= appendDFscripts 0@@ -559,9 +526,9 @@   let k = fromIntegral (length arg)   arg <- zipWithM appendDFscripts [1..k] arg >>= makeITuple   case func of-    Value (TensorData t@(Tensor ns fs js)) ->+    Value (TensorData t@Tensor{}) ->       Value <$> (tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor)-    Intermediate (ITensor t@(Tensor ns fs js)) ->+    Intermediate (ITensor t@Tensor{}) ->       tMap (\f -> applyFunc env f arg) t >>= fromTensor     Value (MemoizedFunc name ref hashRef env names body) -> do       indices <- evalWHNF arg@@ -582,7 +549,7 @@ evalExpr env (MemoizeExpr memoizeFrame expr) = do   mapM_ (\(x, y, z) -> do x' <- evalExprDeep env x                           case x' of-                            (MemoizedFunc name ref hashRef env' names body) -> do+                            MemoizedFunc name ref hashRef env' names body -> do                               indices <- evalExprDeep env y                               indices' <- mapM fromEgison $ fromTupleValue indices                               hash <- liftIO $ readIORef hashRef@@ -605,27 +572,28 @@ evalExpr env (ArrayBoundsExpr expr) =   evalExpr env expr >>= arrayBounds +-- TODO(momohatt): Following numpy's convention, rename 'size' into 'shape'. evalExpr env (GenerateTensorExpr fnExpr sizeExpr) = do-  size' <- evalExpr env sizeExpr-  size'' <- collectionToList size'-  ns <- mapM fromEgison size'' :: EgisonM [Integer]-  let Env frame maybe_vwi = env-  xs <- mapM ((\ms -> do+  size <- evalExpr env sizeExpr >>= collectionToList+  ns   <- mapM fromEgison size :: EgisonM [Integer]+  xs   <- mapM (indexToWHNF env . map toEgison) (enumTensorIndices ns)+  fromTensor (Tensor ns (V.fromList xs) [])+ where+  indexToWHNF :: Env -> [EgisonValue] {- index -} -> EgisonM WHNFData+  indexToWHNF (Env frame maybe_vwi) ms = do     let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi     fn <- evalExpr env' fnExpr-    applyFunc env fn $ Value $ makeTuple ms)-                . map toEgison) (enumTensorIndices ns)-  fromTensor (Tensor ns (V.fromList xs) [])+    applyFunc env fn $ Value $ makeTuple ms  evalExpr env (TensorContractExpr fnExpr tExpr) = do   fn <- evalExpr env fnExpr   whnf <- evalExpr env tExpr   case whnf of-    (Intermediate (ITensor t@Tensor{})) -> do+    Intermediate (ITensor t@Tensor{}) -> do       ts <- tContract t       tMapN (\xs -> do xs' <- mapM newEvaluatedObjectRef xs                        applyFunc env fn (Intermediate (ITuple xs'))) ts >>= fromTensor-    (Value (TensorData t@Tensor{})) -> do+    Value (TensorData t@Tensor{}) -> do       ts <- tContract t       Value <$> (tMapN (applyFunc' env fn . Tuple) ts >>= fromTensor)     _ -> return whnf@@ -749,7 +717,7 @@ applyFunc :: Env -> WHNFData -> WHNFData -> EgisonM WHNFData applyFunc env (Value (TensorData (Tensor s1 t1 i1))) tds = do   tds <- fromTupleWHNF tds-  if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s u i))) -> length s - length i == 1) tds+  if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s _ i))) -> length s - length i == 1) tds     then do       symId <- fresh       let argnum = length tds@@ -761,7 +729,7 @@  applyFunc env (Intermediate (ITensor (Tensor s1 t1 i1))) tds = do   tds <- fromTupleWHNF tds-  if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s u i))) -> length s - length i == 1) tds+  if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s _ i))) -> length s - length i == 1) tds     then do       symId <- fresh       let argnum = length tds@@ -813,24 +781,12 @@   if not (null refs)     then evalExpr (extendEnv env $ makeBindings' [name] [col]) body     else throwError =<< ArgumentsNumWithNames [name] 1 0 <$> getFuncNameStack-applyFunc env (Value (Macro [name] body)) arg = do-  ref <- newEvaluatedObjectRef arg-  evalExpr (extendEnv env $ makeBindings' [name] [ref]) body-applyFunc env (Value (Macro names body)) arg = do-  refs <- fromTuple arg-  if length names == length refs-    then evalExpr (extendEnv env $ makeBindings' names refs) body-    else throwError =<< ArgumentsNumWithNames names (length names) (length refs) <$> getFuncNameStack applyFunc _ (Value (PrimitiveFunc _ func)) arg = func arg applyFunc _ (Value (IOFunc m)) arg =   case arg of      Value World -> m      _           -> throwError =<< TypeMismatch "world" arg <$> getFuncNameStack-applyFunc _ (Value (QuotedFunc fn)) arg = do-  args <- tupleToList arg-  mExprs <- mapM extractScalar args-  return (Value (ScalarData (Div (Plus [Term 1 [(Apply fn mExprs, 1)]]) (Plus [Term 1 []]))))-applyFunc _ (Value fn@(ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])))) arg = do+applyFunc _ (Value (ScalarData fn@(Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])))) arg = do   args <- tupleToList arg   mExprs <- mapM (\arg -> case arg of                             ScalarData _ -> extractScalar arg@@ -847,7 +803,7 @@               then refArray (Value (array Array.! i)) indices               else return  $ Value Undefined     else case index of-           (ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> do+           ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []])) -> do              let (_,size) = Array.bounds array              elms <- mapM (\arr -> refArray (Value arr) indices) (Array.elems array)              elmRefs <- mapM newEvaluatedObjectRef elms@@ -861,7 +817,7 @@                    evalRef ref >>= flip refArray indices               else return  $ Value Undefined     else case index of-           (ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> do+           ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []])) -> do              let (_,size) = Array.bounds array              let refs = Array.elems array              arrs <- mapM evalRef refs@@ -929,7 +885,7 @@  recursiveBind :: Env -> [(Var, EgisonExpr)] -> EgisonM Env recursiveBind env bindings = do-  let (names, exprs) = unzip bindings+  let (names, _) = unzip bindings   refs <- replicateM (length bindings) $ newObjectRef nullEnv UndefinedExpr   let env' = extendEnv env $ makeBindings names refs   let Env frame _ = env'@@ -938,14 +894,14 @@                  MemoizedLambdaExpr names body -> do                    hashRef <- liftIO $ newIORef HL.empty                    liftIO . writeIORef ref . WHNF . Value $ MemoizedFunc (Just name) ref hashRef env' names body-                 LambdaExpr args body -> do+                 LambdaExpr _ _ -> do                    whnf <- evalExpr env' expr                    case whnf of-                     (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body)-                 CambdaExpr arg body -> do+                     Value (Func _ env args body) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body)+                 CambdaExpr _ _ -> do                    whnf <- evalExpr env' expr                    case whnf of-                     (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body)+                     Value (CFunc _ env arg body) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body)                  FunctionExpr args -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ FunctionExpr args                  _ | isVarWithIndices name -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) expr                    | otherwise -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr)@@ -963,14 +919,14 @@                   MemoizedLambdaExpr names body -> do                     hashRef <- liftIO $ newIORef HL.empty                     liftIO . writeIORef ref . WHNF . Value $ MemoizedFunc (Just name) ref hashRef env names body-                  LambdaExpr args body -> do+                  LambdaExpr _ _ -> do                     whnf <- evalExpr env expr                     case whnf of-                      (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body)-                  CambdaExpr arg body -> do+                      Value (Func _ env args body) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body)+                  CambdaExpr _ _ -> do                     whnf <- evalExpr env expr                     case whnf of-                      (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body)+                      Value (CFunc _ env arg body) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body)                   _ -> liftIO . writeIORef ref . Thunk $ evalExpr env expr   return env @@ -979,48 +935,50 @@ --  patternMatch :: PMMode -> Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match)-patternMatch mode env pattern target matcher = processMStates mode [msingleton $ MState env [] [] [] [MAtom pattern target matcher]]+patternMatch pmmode env pattern target matcher =+  case pmmode of+    DFSMode -> processMStatesAllDFS (msingleton initMState)+    BFSMode -> processMStatesAll [msingleton initMState]+  where+    initMState = MState { mStateEnv      = env+                        , loopPatCtx     = []+                        , seqPatCtx      = []+                        , mStateBindings = []+                        , mTrees         = [MAtom pattern target matcher]+                        } -processMStates :: PMMode -> [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match)-processMStates _ [] = return MNil-processMStates mode streams = do-  (matches, streams') <- mapM (processMStates' mode) streams >>= extractMatches . concat-  mappend (fromList matches) $ (processMStates mode) streams'+processMStatesAllDFS :: MList EgisonM MatchingState -> EgisonM (MList EgisonM Match)+processMStatesAllDFS MNil = return MNil+processMStatesAllDFS (MCons (MState _ _ [] bindings []) ms) = MCons bindings . processMStatesAllDFS <$> ms+processMStatesAllDFS (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS -processMStates' :: PMMode -> MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]-processMStates' _ MNil = return []-processMStates' BFSMode stream@(MCons _ _) = processMStatesBFS stream-processMStates' DFSMode stream@(MCons _ _) = processMStatesDFS stream+processMStatesAll :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match)+processMStatesAll [] = return MNil+processMStatesAll streams = do+  (matches, streams') <- mapM processMStates streams >>= extractMatches . concat+  mappend (fromList matches) $ processMStatesAll streams' -gatherBindings :: MatchingState -> Maybe [Binding]-gatherBindings (MState _ _ [] bindings []) = return bindings-gatherBindings _ = Nothing+processMStates :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]+processMStates MNil = return []+processMStates (MCons state stream) = (\x y -> [x, y]) <$> processMState state <*> stream  extractMatches :: [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState]) extractMatches = extractMatches' ([], [])  where   extractMatches' :: ([Match], [MList EgisonM MatchingState]) -> [MList EgisonM MatchingState] -> EgisonM ([Match], [MList EgisonM MatchingState])   extractMatches' (xs, ys) [] = return (xs, ys)-  extractMatches' (xs, ys) ((MCons (gatherBindings -> Just bindings) states):rest) = do+  extractMatches' (xs, ys) (MCons (gatherBindings -> Just bindings) states : rest) = do     states' <- states     extractMatches' (xs ++ [bindings], ys ++ [states']) rest   extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest -processMStatesBFS :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]-processMStatesBFS (MCons state stream) = do-  newStream <- processMState state-  newStream' <- stream-  return [newStream, newStream']--processMStatesDFS :: MList EgisonM MatchingState -> EgisonM [MList EgisonM MatchingState]-processMStatesDFS (MCons state stream) = do-  stream' <- processMState state-  newStream <- mappend stream' stream-  return [newStream]+gatherBindings :: MatchingState -> Maybe [Binding]+gatherBindings mstate@MState{ seqPatCtx = [], mTrees = [] } = return (mStateBindings mstate)+gatherBindings _ = Nothing  topMAtom :: MatchingState -> Maybe MatchingTree-topMAtom (MState _ _ _ _ (mAtom@MAtom{}:_))  = Just mAtom-topMAtom (MState _ _ _ _ (MNode _ mstate:_)) = topMAtom mstate+topMAtom MState{ mTrees = mAtom@MAtom{}:_ }  = Just mAtom+topMAtom MState{ mTrees = MNode _ mstate:_ } = topMAtom mstate topMAtom _ = Nothing  processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState)@@ -1028,108 +986,104 @@   case topMAtom state of     Just (MAtom (NotPat _) _ _) -> do       let (state1, state2) = splitMState state-      result <- processMStates BFSMode [msingleton state1]+      result <- processMStatesAll [msingleton state1]       case result of         MNil -> return $ msingleton state2         _    -> return MNil-    Just (MAtom (LaterPat _) _ _) -> do-      let state' = swapMState state-      processMState' state'     _ -> processMState' state  where   splitMState :: MatchingState -> (MatchingState, MatchingState)-  splitMState (MState env loops seqs bindings (MAtom (NotPat pattern) target matcher : trees)) =-    (MState env loops seqs bindings [MAtom pattern target matcher], MState env loops seqs bindings trees)-  splitMState (MState env loops seqs bindings (MNode penv state' : trees)) =-    let (state1, state2) = splitMState state'-     in (MState env loops seqs bindings [MNode penv state1], MState env loops seqs bindings (MNode penv state2 : trees))-  swapMState :: MatchingState -> MatchingState-  swapMState (MState env loops seqs bindings (MAtom (LaterPat pattern) target matcher : trees)) =-    MState env loops seqs bindings (trees ++ [MAtom pattern target matcher])-  swapMState (MState env loops seqs bindings (MNode penv state' : trees)) =-    let state'' = swapMState state'-     in MState env loops seqs bindings (MNode penv state'':trees)+  splitMState mstate@MState{ mTrees = MAtom (NotPat pattern) target matcher : trees } =+    (mstate { mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees })+  splitMState mstate@MState{ mTrees = MNode penv state' : trees } =+    (mstate { mTrees = [MNode penv state1] }, mstate { mTrees = MNode penv state2 : trees })+      where (state1, state2) = splitMState state'  processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState)-processMState' (MState _ _ [] _ []) = throwError =<< EgisonBug "should not reach here (empty matching-state)" <$> getFuncNameStack+processMState' MState{ seqPatCtx = [], mTrees = [] } = throwError =<< EgisonBug "should not reach here (empty matching-state)" <$> getFuncNameStack -processMState' (MState env loops (SeqPatContext stack SeqNilPat [] []:seqs) bindings []) = return $ msingleton $ MState env loops seqs bindings stack-processMState' (MState env loops (SeqPatContext stack seqPat mats tgts:seqs) bindings []) = do+-- Sequential patterns+processMState' mstate@MState{ seqPatCtx = SeqPatContext stack SeqNilPat [] []:seqs, mTrees = [] } =+  return . msingleton $ mstate { seqPatCtx = seqs, mTrees = stack }+processMState' mstate@MState{ seqPatCtx = SeqPatContext stack seqPat mats tgts:seqs, mTrees = [] } = do   let mat' = makeTuple mats   tgt' <- makeITuple tgts-  return $ msingleton $ MState env loops seqs bindings (MAtom seqPat tgt' mat' : stack)+  return . msingleton $ mstate { seqPatCtx = seqs, mTrees = MAtom seqPat tgt' mat' : stack } -processMState' (MState _ _ _ _ (MNode _ (MState _ _ _ [] []):_)) = throwError =<< EgisonBug "should not reach here (empty matching-node)" <$> getFuncNameStack+-- Matching Nodes+processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwError =<< EgisonBug "should not reach here (empty matching-node)" <$> getFuncNameStack -processMState' (MState env loops seqs bindings (MNode penv (MState env' loops' seqs' bindings' ((MAtom (VarPat name) target matcher):trees')):trees)) =+processMState' ms1@MState{ mTrees = MNode penv ms2@MState{ mTrees = MAtom (VarPat name) target matcher:trees' }:trees } =   case lookup name penv of     Just pattern ->       case trees' of-        [] -> return $ msingleton $ MState env loops seqs bindings ((MAtom pattern target matcher):trees)-        _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target matcher:MNode penv (MState env' loops' seqs' bindings' trees'):trees)+        [] -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:trees }+        _  -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:MNode penv (ms2 { mTrees = trees' }):trees }     Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack -processMState' (MState env loops seqs bindings (MNode penv (MState env' loops' seqs' bindings' (MAtom (IndexedPat (VarPat name) indices) target matcher:trees')):trees)) =+processMState' ms1@(MState _ _ _ bindings (MNode penv ms2@(MState env' loops' _ _ (MAtom (IndexedPat (VarPat name) indices) target matcher:trees')):trees)) =   case lookup name penv of     Just pattern -> do       let env'' = extendEnvForNonLinearPatterns env' bindings loops'       indices' <- mapM (evalExpr env'' >=> fmap fromInteger . fromWHNF) indices       let pattern' = IndexedPat pattern $ map IntegerExpr indices'       case trees' of-        [] -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern' target matcher:trees)-        _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern' target matcher:MNode penv (MState env' loops' seqs' bindings' trees'):trees)+        [] -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:trees }+        _  -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:MNode penv (ms2 { mTrees = trees' }):trees }     Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack -processMState' (MState env loops seqs bindings (MNode penv state:trees)) =+processMState' mstate@MState{ mTrees = MNode penv state:trees } =   processMState' state >>= mmap (\state' -> case state' of-                                              MState _ _ _ _ [] -> return $ MState env loops seqs bindings trees-                                              _ -> return $ MState env loops seqs bindings (MNode penv state':trees))+                                              MState { mTrees = [] } -> return $ mstate { mTrees = trees }+                                              _ -> return $ mstate { mTrees = MNode penv state':trees }) -processMState' (MState env loops seqs bindings (MAtom pattern target matcher:trees)) =+-- Matching Atoms+processMState' mstate@(MState env loops seqs bindings (MAtom pattern target matcher:trees)) =   let env' = extendEnvForNonLinearPatterns env bindings loops in   case pattern of     NotPat _ -> throwError =<< EgisonBug "should not reach here (not pattern)" <$> getFuncNameStack     VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ prettyS pattern -    LetPat bindings' pattern' ->-      let extractBindings ([name], expr) =-            makeBindings [name] . (:[]) <$> newObjectRef env' expr-          extractBindings (names, expr) =-            makeBindings names <$> (evalExpr env' expr >>= fromTuple)-      in-       fmap concat (mapM extractBindings bindings')-         >>= (\b -> return $ msingleton $ MState env loops seqs (b ++ bindings) (MAtom pattern' target matcher:trees))+    LetPat bindings' pattern' -> do+      b <- fmap concat (mapM extractBindings bindings')+      return . msingleton $ mstate { mStateBindings = b ++ bindings, mTrees = MAtom pattern' target matcher:trees }+        where+          extractBindings ([name], expr) = makeBindings [name] . (:[]) <$> newObjectRef env' expr+          extractBindings (names, expr)  = makeBindings names <$> (evalExpr env' expr >>= fromTuple)+     PredPat predicate -> do       func <- evalExpr env' predicate       let arg = target       result <- applyFunc env func arg >>= fromWHNF-      if result then return $ msingleton $ MState env loops seqs bindings trees+      if result then return . msingleton $ mstate { mTrees = trees }                 else return MNil      PApplyPat func args -> do       func' <- evalExpr env' func       case func' of         Value (PatternFunc env'' names expr) ->-          let penv = zip names args-          in return $ msingleton $ MState env loops seqs bindings (MNode penv (MState env'' [] [] [] [MAtom expr target matcher]) : trees)+          return . msingleton $ mstate { mTrees = MNode penv (MState env'' [] [] [] [MAtom expr target matcher]) : trees }+            where penv = zip names args         _ -> throwError =<< TypeMismatch "pattern constructor" func' <$> getFuncNameStack      DApplyPat func args ->-      return $ msingleton $ MState env loops seqs bindings (MAtom (InductivePat "apply" [func, toListPat args]) target matcher:trees)+      return . msingleton $ mstate { mTrees = MAtom (InductivePat "apply" [func, toListPat args]) target matcher:trees }      LoopPat name (LoopRange start ends endPat) pat pat' -> do-      startNum <- evalExpr env' start >>= fromWHNF :: (EgisonM Integer)+      startNum    <- evalExpr env' start >>= fromWHNF :: (EgisonM Integer)       startNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum - 1)-      ends' <- evalExpr env' ends-      if isPrimitiveValue ends'-        then do-          endsRef <- newEvaluatedObjectRef ends'-          inners <- liftIO $ newIORef $ Sq.fromList [IElement endsRef]+      ends'       <- evalExpr env' ends+      case ends' of+        Value (ScalarData _) -> do -- the case when the end numbers are an integer+          endsRef  <- newEvaluatedObjectRef ends'+          inners   <- liftIO . newIORef $ Sq.fromList [IElement endsRef]           endsRef' <- liftIO $ newIORef (WHNF (Intermediate (ICollection inners)))-          return $ msingleton $ MState env (LoopPatContext (name, startNumRef) endsRef' endPat pat pat':loops) seqs bindings (MAtom ContPat target matcher:trees)-        else do+          return . msingleton $ mstate { loopPatCtx = LoopPatContext (name, startNumRef) endsRef' endPat pat pat':loops+                                       , mTrees = MAtom ContPat target matcher:trees }+        _ -> do -- the case when the end numbers are a collection           endsRef <- newEvaluatedObjectRef ends'-          return $ msingleton $ MState env (LoopPatContext (name, startNumRef) endsRef endPat pat pat':loops) seqs bindings (MAtom ContPat target matcher:trees)+          return . msingleton $ mstate { loopPatCtx = LoopPatContext (name, startNumRef) endsRef endPat pat pat':loops+                                       , mTrees = MAtom ContPat target matcher:trees }     ContPat ->       case loops of         [] -> throwError $ Default "cannot use cont pattern except in loop pattern"@@ -1148,24 +1102,24 @@               return $ if                 | startNum >  carEndsNum -> MNil                 | startNum == carEndsNum && b2 ->-                  fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees)]+                  fromList [mstate { loopPatCtx = loops', mTrees = MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees }]                 | startNum == carEndsNum ->-                  fromList [MState env loops' seqs bindings (MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees),-                            MState env (LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)]+                  fromList [mstate { loopPatCtx = loops', mTrees = MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees },+                            mstate { loopPatCtx = LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }]                 | otherwise ->-                  fromList [MState env (LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops') seqs bindings (MAtom pat target matcher:trees)]+                  fromList [mstate { loopPatCtx = LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }]     SeqNilPat -> throwError =<< EgisonBug "should not reach here (seq nil pattern)" <$> getFuncNameStack-    SeqConsPat pattern pattern' -> return $ msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher]+    SeqConsPat pattern pattern' -> return . msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher]     LaterPatVar ->       case seqs of         [] -> throwError $ Default "cannot use # out of seq patterns"-        (SeqPatContext stack pat mats tgts:seqs) -> return $ msingleton $ MState env loops (SeqPatContext stack pat (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees+        (SeqPatContext stack pat mats tgts:seqs) -> return . msingleton $ MState env loops (SeqPatContext stack pat (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees     AndPat patterns ->       let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees-      in return $ msingleton $ MState env loops seqs bindings trees'+       in return . msingleton $ mstate { mTrees = trees' }     OrPat patterns ->       return $ fromList $ flip map patterns $ \pat ->-        MState env loops seqs bindings (MAtom pat target matcher : trees)+        mstate { mTrees = MAtom pat target matcher : trees }      _ ->       case matcher of@@ -1176,25 +1130,25 @@               mfor targetss $ \ref -> do                 targets <- evalRef ref >>= (\x -> return [x])                 let trees' = zipWith3 MAtom patterns targets matchers ++ trees-                return $ MState env loops seqs bindings trees'+                return $ mstate { mTrees = trees' }             _ ->               mfor targetss $ \ref -> do                 targets <- evalRef ref >>= fromTupleWHNF                 let trees' = zipWith3 MAtom patterns targets matchers ++ trees-                return $ MState env loops seqs bindings trees'+                return $ mstate { mTrees = trees' }          Tuple matchers ->           case pattern of-            ValuePat _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees)-            WildCard -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees)-            PatVar _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees)-            IndexedPat _ _ -> return $ msingleton $ MState env loops seqs bindings (MAtom pattern target Something:trees)+            ValuePat _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees }+            WildCard   -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees }+            PatVar _   -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees }+            IndexedPat _ _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees }             TuplePat patterns -> do               targets <- fromTupleWHNF target               when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack               when (length patterns /= length matchers) $ throwError =<< TupleLength (length patterns) (length matchers) <$> getFuncNameStack               let trees' = zipWith3 MAtom patterns targets matchers ++ trees-              return $ msingleton $ MState env loops seqs bindings trees'+              return . msingleton $ mstate { mTrees = trees' }             _ ->  throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern          Something ->@@ -1203,21 +1157,21 @@               val <- evalExprDeep env' valExpr               tgtVal <- evalWHNF target               if val == tgtVal-                then return $ msingleton $ MState env loops seqs bindings trees+                then return . msingleton $ mstate { mTrees = trees }                 else return MNil-            WildCard -> return $ msingleton $ MState env loops seqs bindings trees+            WildCard -> return . msingleton $ mstate { mTrees = trees }             PatVar name -> do               targetRef <- newEvaluatedObjectRef target-              return $ msingleton $ MState env loops seqs ((name, targetRef):bindings) trees+              return . msingleton $ mstate { mStateBindings = (name, targetRef):bindings, mTrees = trees }             IndexedPat (PatVar name) indices -> do               indices <- mapM (evalExpr env' >=> fmap fromInteger . fromWHNF) indices               case lookup name bindings of                 Just ref -> do                   obj <- evalRef ref >>= updateHash indices >>= newEvaluatedObjectRef-                  return $ msingleton $ MState env loops seqs (subst name obj bindings) trees+                  return . msingleton $ mstate { mStateBindings = subst name obj bindings, mTrees = trees }                 Nothing  -> do                   obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvaluatedObjectRef-                  return $ msingleton $ MState env loops seqs ((name,obj):bindings) trees+                  return . msingleton $ mstate { mStateBindings = (name,obj):bindings, mTrees = trees }                where                 updateHash :: [Integer] -> WHNFData -> EgisonM WHNFData                 updateHash [index] (Intermediate (IIntHash hash)) = do@@ -1236,12 +1190,12 @@                 subst k nv ((k', v'):xs) | k == k'   = (k', nv):subst k nv xs                                          | otherwise = (k', v'):subst k nv xs                 subst _ _ [] = []-            IndexedPat pattern indices -> throwError $ Default ("invalid indexed-pattern: " ++ prettyS pattern)+            IndexedPat pattern _ -> throwError $ Default ("invalid indexed-pattern: " ++ prettyS pattern)             TuplePat patterns -> do               targets <- fromTupleWHNF target               when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack               let trees' = zipWith3 MAtom patterns targets (replicate (length patterns) Something) ++ trees-              return $ msingleton $ MState env loops seqs bindings trees'+              return . msingleton $ mstate { mTrees = trees' }             _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ prettyS pattern         _ ->  throwError =<< EgisonBug ("should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern) <$> getFuncNameStack @@ -1328,9 +1282,18 @@   (++) <$> primitiveDataPatternMatch pattern init'        <*> primitiveDataPatternMatch pattern' last' primitiveDataPatternMatch (PDConstantPat expr) whnf = do-  target <- (either (const matchFail) return) $ extractPrimitiveValue whnf+  target <- either (const matchFail) return $ extractPrimitiveValue whnf   isEqual <- lift $ (==) <$> evalExprDeep nullEnv expr <*> pure target   if isEqual then return [] else matchFail+ where+  extractPrimitiveValue :: WHNFData -> Either ([String] -> EgisonError) EgisonValue+  extractPrimitiveValue (Value val@(Char _)) = return val+  extractPrimitiveValue (Value val@(Bool _)) = return val+  extractPrimitiveValue (Value val@(ScalarData _)) = return val+  extractPrimitiveValue (Value val@(Float _)) = return val+  extractPrimitiveValue whnf =+    -- we don't need to extract call stack since detailed error information is not used+    throwError $ TypeMismatch "primitive value" whnf  expandCollection :: WHNFData -> EgisonM (Seq Inner) expandCollection (Value (Collection vals)) =@@ -1465,41 +1428,3 @@ makeITuple []  = return $ Intermediate (ITuple []) makeITuple [x] = return x makeITuple xs  = Intermediate . ITuple <$> mapM newEvaluatedObjectRef xs------- String----packStringValue :: EgisonValue -> EgisonM Text-packStringValue (Collection seq) = do-  let ls = toList seq-  str <- mapM (\val -> case val of-                         Char c -> return c-                         _ -> throwError =<< TypeMismatch "char" (Value val) <$> getFuncNameStack)-              ls-  return $ T.pack str-packStringValue (Tuple [val]) = packStringValue val-packStringValue val = throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack------- Util----data EgisonHashKey =-    IntKey Integer-  | CharKey Char-  | StrKey Text--extractPrimitiveValue :: WHNFData -> Either ([String] -> EgisonError) EgisonValue-extractPrimitiveValue (Value val@(Char _)) = return val-extractPrimitiveValue (Value val@(Bool _)) = return val-extractPrimitiveValue (Value val@(ScalarData _)) = return val-extractPrimitiveValue (Value val@(Float _)) = return val-extractPrimitiveValue whnf =-  -- we don't need to extract call stack since detailed error information is not used-  throwError $ TypeMismatch "primitive value" whnf--isPrimitiveValue :: WHNFData -> Bool-isPrimitiveValue (Value (Char _))       = True-isPrimitiveValue (Value (Bool _))       = True-isPrimitiveValue (Value (ScalarData _)) = True-isPrimitiveValue (Value (Float _))      = True-isPrimitiveValue _                      = False

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE TupleSections              #-} @@ -17,6 +16,7 @@     , desugarExpr     ) where +import           Control.Monad.Except  (throwError) import           Data.Char             (toUpper) import           Data.List             (span) import           Data.Set              (Set)@@ -27,6 +27,12 @@  desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr desugarTopExpr (Define name expr)   = Define name <$> desugar expr+desugarTopExpr (DefineWithIndices (VarWithIndices name is) expr) = do+  body <- desugar expr+  let indexNames = map extractIndex is+  let indexNamesCollection = CollectionExpr (map (ElementExpr . stringToVarExpr) indexNames)+  return $ Define (Var name (map (const () <$>) is))+    (WithSymbolsExpr indexNames (TransposeExpr indexNamesCollection body)) desugarTopExpr (Redefine name expr) = Redefine name <$> desugar expr desugarTopExpr (Test expr)          = Test <$> desugar expr desugarTopExpr (Execute expr)       = Execute <$> desugar expr@@ -118,39 +124,30 @@     (TupleExpr nums') -> desugar $ IndexedExpr True expr (map Subscript nums')     _ -> desugar $ IndexedExpr True expr [Subscript nums] -desugar (IndexedExpr b expr indices)-  | endWithThreeDots expr =-    case expr of-      VarExpr name ->-        let x = show name-         in desugar $ IndexedExpr False (stringToVarExpr $ take (length x - 3) x) indices-  | otherwise =-    case indices of-      [Subscript x, DotSubscript y] ->-        case (x, y) of-          (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (makeApply "between" [x, y])-          (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do-            k <- fresh-            return $ SubrefsExpr b expr (makeApply "map"-                                                   [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ stringToVarExpr k]),-                                                    makeApply "between" [fromIndexToExpr n1, fromIndexToExpr n2]])-      [Superscript x, DotSupscript y] ->-        case (x, y) of-          (IntegerExpr _, IntegerExpr _) -> return $ SubrefsExpr b expr (makeApply "between" [x, y])-          (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr b2 e2 [n2]]) -> do-            k <- fresh-            return $ SuprefsExpr b expr (makeApply "map"-                                                   [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ stringToVarExpr k]),-                                                    makeApply "between" [fromIndexToExpr n1, fromIndexToExpr n2]])-      _ -> IndexedExpr b <$> desugar expr <*> mapM desugarIndex indices- where-  endWithThreeDots :: EgisonExpr -> Bool-  endWithThreeDots (VarExpr name) = take 3 (reverse (show name)) == "..."-  endWithThreeDots _              = False-  fromIndexToExpr :: Index EgisonExpr -> EgisonExpr-  fromIndexToExpr (Subscript a)    = a-  fromIndexToExpr (Superscript a)  = a-  fromIndexToExpr (SupSubscript a) = a+-- TODO: Allow nested MultiSubscript and MultiSuperscript+desugar (IndexedExpr b expr indices) =+  case indices of+    [MultiSubscript x y] ->+      case (x, y) of+        (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) ->+          desugarMultiScript SubrefsExpr b1 e1 n1 n2+        (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr _ _ [n2]]) ->+          desugarMultiScript SubrefsExpr b1 e1 n1 n2+        _ -> throwError $ Default "Index should be IndexedExpr for multi subscript"+    [MultiSuperscript x y] ->+      case (x, y) of+        (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) ->+          desugarMultiScript SuprefsExpr b1 e1 n1 n2+        (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr _ _ [n2]]) ->+          desugarMultiScript SuprefsExpr b1 e1 n1 n2+        _ -> throwError $ Default "Index should be IndexedExpr for multi superscript"+    _ -> IndexedExpr b <$> desugar expr <*> mapM desugarIndex indices+  where+    desugarMultiScript refExpr b1 e1 n1 n2 = do+      k <- fresh+      return $ refExpr b expr (makeApply "map"+                                         [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ stringToVarExpr k]),+                                          makeApply "between" [extractIndex n1, extractIndex n2]])  desugar (SubrefsExpr bool expr1 expr2) =   SubrefsExpr bool <$> desugar expr1 <*> desugar expr2@@ -199,23 +196,22 @@                                     _           -> False) (reverse names)   case rhnames of     [] -> LambdaExpr names <$> desugar expr-    (InvertedScalarArg rhname:rhnames') -> do-      let (rtnames2, rhnames2) = span (const False) rhnames'-      case rhnames2 of+    InvertedScalarArg rhname:rhnames' ->+      case rhnames' of         [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames)                           (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (FlipIndicesExpr (stringToVarExpr rhname)))-        (ScalarArg rhname2:rhnames2') ->-          desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames)+        ScalarArg rhname2:rhnames2' ->+          desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2, TensorArg rhname] ++ reverse rtnames)                       (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr)                                       (stringToVarExpr rhname2)                                       (FlipIndicesExpr (stringToVarExpr rhname)))-        (InvertedScalarArg rhname2:rhnames2') ->-          desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames)+        InvertedScalarArg rhname2:rhnames2' ->+          desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2, TensorArg rhname] ++ reverse rtnames)                       (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr)                                       (FlipIndicesExpr (stringToVarExpr rhname2))                                       (FlipIndicesExpr (stringToVarExpr rhname))) -    (ScalarArg rhname:rhnames') -> do+    ScalarArg rhname:rhnames' -> do       let (rtnames2, rhnames2) = span (\case                                           TensorArg _ -> True                                           _           -> False) rhnames'@@ -286,7 +282,7 @@ desugar (UnaryOpExpr "'" expr) = QuoteExpr <$> desugar expr desugar (UnaryOpExpr "`" expr) = QuoteSymbolExpr <$> desugar expr -desugar (BinaryOpExpr op expr1 expr2) | isWedge op = do+desugar (BinaryOpExpr op expr1 expr2) | isWedge op =   (\x y -> WedgeApplyExpr (stringToVarExpr (func op)) (TupleExpr [x, y]))     <$> desugar expr1 <*> desugar expr2 @@ -351,10 +347,7 @@ desugar expr = return expr  desugarIndex :: Index EgisonExpr -> EgisonM (Index EgisonExpr)-desugarIndex (Superscript expr)  = Superscript  <$> desugar expr-desugarIndex (Subscript expr)    = Subscript    <$> desugar expr-desugarIndex (SupSubscript expr) = SupSubscript <$> desugar expr-desugarIndex (Userscript expr)   = Userscript   <$> desugar expr+desugarIndex index = traverse desugar index  desugarPattern :: EgisonPattern -> EgisonM EgisonPattern desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern@@ -364,7 +357,6 @@     collectName :: EgisonPattern -> Set String    collectName (NotPat pattern) = collectName pattern-   collectName (LaterPat pattern) = collectName pattern    collectName (AndPat patterns) = collectNames patterns    collectName (TuplePat patterns) = collectNames patterns    collectName (InductivePat _ patterns) = collectNames patterns@@ -387,7 +379,6 @@ desugarPattern' (ValuePat expr) = ValuePat <$> desugar expr desugarPattern' (PredPat expr) = PredPat <$> desugar expr desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern-desugarPattern' (LaterPat pattern) = LaterPat <$> desugarPattern' pattern desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns desugarPattern' (OrPat patterns)  =  OrPat <$> mapM desugarPattern' patterns desugarPattern' (TuplePat patterns)  = TuplePat <$> mapM desugarPattern' patterns

@@ -0,0 +1,295 @@+{-# LANGUAGE FlexibleInstances #-}++{- |+Module      : Language.Egison.MathExpr+Copyright   : Satoshi Egi+Licence     : MIT++This module contains functions for mathematical expressions.+-}++module Language.Egison.MathExpr+    (+    -- * MathExpr Data+      ScalarData (..)+    , PolyExpr (..)+    , TermExpr (..)+    , SymbolExpr (..)+    -- * Scalar+    , mathNormalize'+    , mathFold+    , mathSymbolFold+    , mathTermFold+    , mathRemoveZero+    , mathDivide+    , mathPlus+    , mathMult+    , mathNegate+    , mathNumerator+    , mathDenominator+    ) where++import           Prelude                   hiding (foldr, mappend, mconcat)+import           Data.List                 (any, elemIndex, intercalate, splitAt)++import           Language.Egison.AST++--+-- Data+--+++data ScalarData =+    Div PolyExpr PolyExpr+ deriving (Eq)++newtype PolyExpr =+    Plus [TermExpr]++data TermExpr =+    Term Integer Monomial++type Monomial = [(SymbolExpr, Integer)]++data SymbolExpr =+    Symbol Id String [Index ScalarData]+  | Apply ScalarData [ScalarData]+  | Quote ScalarData+  | FunctionData ScalarData [ScalarData] [ScalarData] [Index ScalarData] -- fnname argnames args indices+ deriving (Eq)++type Id = String++instance Eq PolyExpr where+  (Plus []) == (Plus []) = True+  (Plus (x:xs)) == (Plus ys) =+    case elemIndex x ys of+      Just i -> let (hs, _:ts) = splitAt i ys in+                  Plus xs == Plus (hs ++ ts)+      Nothing -> False+  _ == _ = False++instance Eq TermExpr where+  (Term a []) == (Term b []) = a == b+  (Term a ((Quote x, n):xs)) == (Term b ys)+    | (a /= b) && (a /= -b) = False+    | otherwise = case elemIndex (Quote x, n) ys of+                    Just i -> let (hs, _:ts) = splitAt i ys in+                                Term a xs == Term b (hs ++ ts)+                    Nothing -> case elemIndex (Quote (mathNegate x), n) ys of+                                 Just i -> let (hs, _:ts) = splitAt i ys in+                                             if even n+                                               then Term a xs == Term b (hs ++ ts)+                                               else Term (-a) xs == Term b (hs ++ ts)+                                 Nothing -> False+  (Term a (x:xs)) == (Term b ys)+    | (a /= b) && (a /= -b) = False+    | otherwise = case elemIndex x ys of+                    Just i -> let (hs, _:ts) = splitAt i ys in+                                Term a xs == Term b (hs ++ ts)+                    Nothing -> False+  _ == _ = False++instance Show ScalarData where+  show (Div p1 (Plus [Term 1 []])) = show p1+  show (Div p1 p2)                 = show' p1 ++ " / " ++ show' p2+    where+      show' :: PolyExpr -> String+      show' p@(Plus [_]) = show p+      show' p            = "(" ++ show p ++ ")"++instance Show PolyExpr where+  show (Plus [])  = "0"+  show (Plus ts)  = intercalate " + " (map show ts)++instance Show TermExpr where+  show (Term a []) = show a+  show (Term 1 xs) = intercalate " * " (map showPoweredSymbol xs)+  show (Term a xs) = intercalate " * " (show a : map showPoweredSymbol xs)++showPoweredSymbol :: (SymbolExpr, Integer) -> String+showPoweredSymbol (x, 1) = show x+showPoweredSymbol (x, n) = show x ++ "^" ++ show n++instance Show SymbolExpr where+  show (Symbol _ (':':':':':':_) []) = "#"+  show (Symbol _ s []) = s+  show (Symbol _ s js) = s ++ concatMap show js+  show (Apply fn mExprs) = "(" ++ show fn ++ " " ++ unwords (map show mExprs) ++ ")"+  show (Quote mExprs) = "'(" ++ show mExprs ++ ")"+  show (FunctionData name _ _ js) = show name ++ concatMap show js++instance Show (Index ScalarData) where+  show (Superscript i)  = "~" ++ show i+  show (Subscript i)    = "_" ++ show i+  show (SupSubscript i) = "~_" ++ show i+  show (DFscript _ _)   = ""+  show (Userscript i)   = "|" ++ show i++--+-- Scalars+--++mathNormalize' :: ScalarData -> ScalarData+mathNormalize' = mathDivide . mathRemoveZero . mathFold . mathRemoveZeroSymbol++termsGcd :: [TermExpr] -> TermExpr+termsGcd ts@(_:_) =+  foldl1 (\(Term a xs) (Term b ys) -> Term (gcd a b) (monoGcd xs ys)) ts+ where+  monoGcd :: Monomial -> Monomial -> Monomial+  monoGcd [] _ = []+  monoGcd ((x, n):xs) ys =+    case f (x, n) ys of+      (_, 0) -> monoGcd xs ys+      (z, m) -> (z, m) : monoGcd xs ys++  f :: (SymbolExpr, Integer) -> Monomial -> (SymbolExpr, Integer)+  f (x, _) [] = (x, 0)+  f (Quote x, n) ((Quote y, m):ys)+    | x == y            = (Quote x, min n m)+    | x == mathNegate y = (Quote x, min n m)+    | otherwise         = f (Quote x, n) ys+  f (x, n) ((y, m):ys)+    | x == y    = (x, min n m)+    | otherwise = f (x, n) ys++mathDivide :: ScalarData -> ScalarData+mathDivide mExpr@(Div (Plus _) (Plus [])) = mExpr+mathDivide mExpr@(Div (Plus []) (Plus _)) = mExpr+mathDivide (Div (Plus ts1) (Plus ts2)) =+  let z@(Term c zs) = termsGcd (ts1 ++ ts2) in+  case ts2 of+    [Term a _] | a < 0 -> Div (Plus (map (`mathDivideTerm` Term (-c) zs) ts1))+                              (Plus (map (`mathDivideTerm` Term (-c) zs) ts2))+    _                  -> Div (Plus (map (`mathDivideTerm` z) ts1))+                              (Plus (map (`mathDivideTerm` z) ts2))++mathDivideTerm :: TermExpr -> TermExpr -> TermExpr+mathDivideTerm (Term a xs) (Term b ys) =+  let (sgn, zs) = f 1 xs ys in+  Term (sgn * div a b) zs+ where+  f :: Integer -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Integer, [(SymbolExpr, Integer)])+  f sgn xs [] = (sgn, xs)+  f sgn xs ((y, n):ys) =+    let (sgns, zs) = unzip (map (\(x, m) -> g (x, m) (y, n)) xs) in+    f (sgn * product sgns) zs ys+  g :: (SymbolExpr, Integer) -> (SymbolExpr, Integer) -> (Integer, (SymbolExpr, Integer))+  g (Quote x, n) (Quote y, m)+    | x == y            = (1, (Quote x, n - m))+    | x == mathNegate y = if even m then (1, (Quote x, n - m)) else (-1, (Quote x, n - m))+    | otherwise         = (1, (Quote x, n))+  g (x, n) (y, m)+    | x == y    = (1, (x, n - m))+    | otherwise = (1, (x, n))++mathRemoveZeroSymbol :: ScalarData -> ScalarData+mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) =+  let ts1' = map (\(Term a xs) -> Term a (filter p xs)) ts1+      ts2' = map (\(Term a xs) -> Term a (filter p xs)) ts2+   in Div (Plus ts1') (Plus ts2')+  where+    p (_, 0) = False+    p _      = True++mathRemoveZero :: ScalarData -> ScalarData+mathRemoveZero (Div (Plus ts1) (Plus ts2)) =+  let ts1' = filter (\(Term a _) -> a /= 0) ts1 in+  let ts2' = filter (\(Term a _) -> a /= 0) ts2 in+    case ts1' of+      [] -> Div (Plus []) (Plus [Term 1 []])+      _  -> Div (Plus ts1') (Plus ts2')++mathFold :: ScalarData -> ScalarData+mathFold = mathTermFold . mathSymbolFold . mathTermFold++-- x^2 y x -> x^3 y+mathSymbolFold :: ScalarData -> ScalarData+mathSymbolFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (map f ts1)) (Plus (map f ts2))+ where+  f :: TermExpr -> TermExpr+  f (Term a xs) = let (ys, sgns) = unzip $ g [] xs+                   in Term (product sgns * a) ys+  g :: [((SymbolExpr, Integer),Integer)] -> [(SymbolExpr, Integer)] -> [((SymbolExpr, Integer),Integer)]+  g ret [] = ret+  g ret ((x, n):xs)+    | any (p (x, n)) ret = g (map (h (x, n)) ret) xs+    | otherwise          = g (ret ++ [((x, n), 1)]) xs+  p :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> Bool+  p (Quote x, _) ((Quote y, _),_) = (x == y) || (mathNegate x == y)+  p (x, _) ((y, _),_)             = x == y+  h :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> ((SymbolExpr, Integer), Integer)+  h (Quote x, n) ((Quote y, m), sgn)+    | x == y = ((Quote y, m + n), sgn)+    | x == mathNegate y = if even n then ((Quote y, m + n), sgn) else ((Quote y, m + n), -1 * sgn)+    | otherwise = ((Quote y, m), sgn)+  h (x, n) ((y, m), sgn) = if x == y+                             then ((y, m + n), sgn)+                             else ((y, m), sgn)++-- x^2 y + x^2 y -> 2 x^2 y+mathTermFold :: ScalarData -> ScalarData+mathTermFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (f ts1)) (Plus (f ts2))+ where+  f :: [TermExpr] -> [TermExpr]+  f = f' []+  f' :: [TermExpr] -> [TermExpr] -> [TermExpr]+  f' ret [] = ret+  f' ret (Term a xs:ts) =+    if any (\(Term _ ys) -> fst (p 1 xs ys)) ret+      then f' (map (g (Term a xs)) ret) ts+      else f' (ret ++ [Term a xs]) ts+  g :: TermExpr -> TermExpr -> TermExpr+  g (Term a xs) (Term b ys) = let (c, sgn) = p 1 xs ys in+                                if c+                                  then Term ((sgn * a) + b) ys+                                  else Term b ys+  p :: Integer -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Bool, Integer)+  p sgn [] [] = (True, sgn)+  p _   [] _  = (False, 0)+  p sgn ((x, n):xs) ys =+    let (b, ys', sgn2) = q (x, n) [] ys in+      if b+        then p (sgn * sgn2) xs ys'+        else (False, 0)+  q :: (SymbolExpr, Integer) -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Bool, [(SymbolExpr, Integer)], Integer)+  q _ _ [] = (False, [], 1)+  q (Quote x, n) ret ((Quote y, m):ys)+    | (x == y) && (n == m) = (True, ret ++ ys, 1)+    | (mathNegate x == y) && (n == m) = if even n then (True, ret ++ ys, 1) else (True, ret ++ ys, -1)+    | otherwise = q (Quote x, n) (ret ++ [(Quote y, m)]) ys+  q (Quote x, n) ret ((y,m):ys) = q (Quote x, n) (ret ++ [(y, m)]) ys+  q (x, n) ret ((y, m):ys) = if (x == y) && (n == m)+                               then (True, ret ++ ys, 1)+                               else q (x, n) (ret ++ [(y, m)]) ys++--+--  Arithmetic operations+--++mathPlus :: ScalarData -> ScalarData -> ScalarData+mathPlus (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathPlusPoly (mathMultPoly m1 n2) (mathMultPoly m2 n1)) (mathMultPoly n1 n2)++mathPlusPoly :: PolyExpr -> PolyExpr -> PolyExpr+mathPlusPoly (Plus ts1) (Plus ts2) = Plus (ts1 ++ ts2)++mathMult :: ScalarData -> ScalarData -> ScalarData+mathMult (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathMultPoly m1 m2) (mathMultPoly n1 n2)++mathMultPoly :: PolyExpr -> PolyExpr -> PolyExpr+mathMultPoly (Plus []) (Plus _) = Plus []+mathMultPoly (Plus _) (Plus []) = Plus []+mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> Plus (map (\(Term b ys) -> Term (a * b) (xs ++ ys)) ts2)) ts1)++mathNegate :: ScalarData -> ScalarData+mathNegate (Div m n) = Div (mathNegate' m) n++mathNegate' :: PolyExpr -> PolyExpr+mathNegate' (Plus ts) = Plus (map (\(Term a xs) -> Term (-a) xs) ts)++mathNumerator :: ScalarData -> ScalarData+mathNumerator (Div m _) = Div m (Plus [Term 1 []])++mathDenominator :: ScalarData -> ScalarData+mathDenominator (Div _ n) = Div n (Plus [Term 1 []])

@@ -20,7 +20,7 @@   -- 'lang' is either "asciimath", "latex", "mathematica" or "maxima"   -- Other invalid options are rejected in Interpreter/egison.hs   case parse parseExpr "math-expr" input of-    Left err  -> input+    Left _ -> input     Right val -> case showMathExpr lang val of                    "undefined" -> "undefined"                    output      -> "#" ++ lang ++ "|" ++ output ++ "|#"@@ -31,6 +31,7 @@ showMathExpr "mathematica" = showMathExprMathematica showMathExpr "maxima"      = showMathExprMaxima showMathExpr "haskell"     = show+showMathExpr _             = error "Unreachable"  data MathExpr   = Atom String [MathIndex]@@ -160,12 +161,12 @@ showMathExprLatexSuper :: MathIndex -> String showMathExprLatexSuper (Super (Atom "#" [])) = "\\#" showMathExprLatexSuper (Super x)             = showMathExprLatex x-showMathExprLatexSuper (Sub x)               = "\\;"+showMathExprLatexSuper (Sub _)               = "\\;"  showMathExprLatexSub :: MathIndex -> String showMathExprLatexSub (Sub (Atom "#" [])) = "\\#" showMathExprLatexSub (Sub x)             = showMathExprLatex x-showMathExprLatexSub (Super x)           = "\\;"+showMathExprLatexSub (Super _)           = "\\;"  showMathExprLatexScript :: [MathIndex] -> String showMathExprLatexScript [] = ""@@ -240,7 +241,7 @@  showMathExprMaxima :: MathExpr -> String showMathExprMaxima (Atom a []) = a-showMathExprMaxima (Partial f xs) = "undefined"+showMathExprMaxima (Partial _ _) = "undefined" showMathExprMaxima (NegativeAtom a) = "-" ++ a showMathExprMaxima (Plus []) = "" showMathExprMaxima (Plus (x:xs)) = showMathExprMaxima x ++ showMathExprMaximaForPlus xs@@ -264,19 +265,19 @@    addBracket x@(Atom _ []) = showMathExprMaxima x    addBracket x             = "(" ++ showMathExprMaxima x ++ ")" showMathExprMaxima (Func f xs) = showMathExprMaxima f ++ "(" ++ showMathExprMaximaArg xs ++ ")"-showMathExprMaxima (Tensor lvs mis) = "undefined"-showMathExprMaxima (Tuple xs) = "undefined"+showMathExprMaxima (Tensor _ _) = "undefined"+showMathExprMaxima (Tuple _) = "undefined" showMathExprMaxima (Collection xs) = "[" ++ showMathExprMaximaArg xs ++ "]" showMathExprMaxima (Exp x) = "exp(" ++ showMathExprMaxima x ++ ")" showMathExprMaxima (Quote x) = "(" ++ showMathExprMaxima x ++ ")"  showMathExprMaxima' :: MathExpr -> String-showMathExprMaxima' (Plus xs) = "(" ++ showMathExprMaxima (Plus xs) ++ ")"+showMathExprMaxima' x@(Plus _) = "(" ++ showMathExprMaxima x ++ ")" showMathExprMaxima' x         = showMathExprMaxima x  showMathExprMaximaArg :: [MathExpr] -> String showMathExprMaximaArg [] = ""-showMathExprMaximaArg [Tensor lvs []] = "undefined"+showMathExprMaximaArg [Tensor _ []] = "undefined" showMathExprMaximaArg [a] = showMathExprMaxima a showMathExprMaximaArg lvs = showMathExprMaxima (head lvs) ++ ", " ++ showMathExprMaximaArg (tail lvs) 

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections    #-}+{-# OPTIONS_GHC -Wno-all      #-} -- Since we will soon deprecate this parser  {- | Module      : Language.Egison.Parser@@ -25,8 +26,6 @@        , loadFile        ) where -import           Prelude                 hiding (mapM)- import           Control.Applicative     (pure, (*>), (<$>), (<*), (<*>)) import           Control.Monad.Except    (liftIO, throwError) import           Control.Monad.Identity  (Identity, unless)@@ -38,7 +37,6 @@ import           Data.Ratio import qualified Data.Set                as Set import qualified Data.Text               as T-import           Data.Traversable        (mapM)  import           Text.Parsec import           Text.Parsec.String@@ -103,7 +101,7 @@   unless doesExist $ throwError $ Default ("file does not exist: " ++ file)   input <- liftIO $ readUTF8File file   exprs <- readTopExprs $ shebang input-  concat <$> mapM  recursiveLoad exprs+  concat <$> mapM recursiveLoad exprs  where   recursiveLoad (Load file)     = loadLibraryFile file   recursiveLoad (LoadFile file) = loadFile file@@ -147,16 +145,7 @@  defineExpr :: Parser EgisonTopExpr defineExpr = try (parens (keywordDefine >> Define <$> (char '$' >> identVar) <*> expr))-         <|> try (parens (do keywordDefine-                             (VarWithIndices name is) <- char '$' >> identVarWithIndices-                             Define (Var name (map f is)) . WithSymbolsExpr (map g is) . TransposeExpr (CollectionExpr (map (ElementExpr . VarExpr . stringToVar . g) is)) <$> expr))- where-  f (Superscript _)  = Superscript ()-  f (Subscript _)    = Subscript ()-  f (SupSubscript _) = SupSubscript ()-  g (Superscript i)  = i-  g (Subscript i)    = i-  g (SupSubscript i) = i+         <|> try (parens (keywordDefine >> DefineWithIndices <$> (char '$' >> identVarWithIndices) <*> expr))  redefineExpr :: Parser EgisonTopExpr redefineExpr = (keywordRedefine <|> keywordSet) >> Redefine <$> (char '$' >> identVar) <*> expr@@ -210,7 +199,6 @@                         <|> memoizeExpr                         <|> cambdaExpr                         <|> procedureExpr-                        <|> macroExpr                         <|> patternFunctionExpr                         <|> letRecExpr                         <|> letExpr@@ -399,9 +387,6 @@ procedureExpr :: Parser EgisonExpr procedureExpr = keywordProcedure >> ProcedureExpr <$> varNames <*> expr -macroExpr :: Parser EgisonExpr-macroExpr = keywordMacro >> MacroExpr <$> varNames <*> expr- patternFunctionExpr :: Parser EgisonExpr patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern @@ -580,7 +565,6 @@                     <|> orPat                     <|> loopPat                     <|> letPat-                    <|> laterPat                     <|> try divPat                     <|> try plusPat                     <|> try multPat@@ -611,9 +595,6 @@ letPat :: Parser EgisonPattern letPat = keywordLet >> LetPat <$> bindings <*> pattern -laterPat :: Parser EgisonPattern-laterPat = keywordLater >> LaterPat <$> pattern- notPat :: Parser EgisonPattern notPat = char '!' >> NotPat <$> pattern @@ -738,8 +719,9 @@                 , P.nestedComments     = True                 , P.caseSensitive      = True } -symbol0 = oneOf "^"-symbol1 = oneOf "+-*/.=∂∇"+symbol0 = char '^'+-- Don't allow three consecutive dots to be a part of identifier+symbol1 = oneOf "+-*/=∂∇" <|> try (char '.' <* notFollowedBy (string "..")) symbol2 = symbol1 <|> oneOf "'!?₀₁₂₃₄₅₆₇₈₉"  lexer :: P.GenTokenParser String () Identity@@ -763,7 +745,6 @@   , "memoize"   , "cambda"   , "procedure"-  , "macro"   , "pattern-function"   , "letrec"   , "let"@@ -834,7 +815,6 @@ keywordNot                  = reserved "not" keywordAnd                  = reserved "and" keywordOr                   = reserved "or"-keywordLater                = reserved "later" keywordSeq                  = reserved "seq" keywordApply                = reserved "apply" keywordCApply               = reserved "capply"@@ -843,7 +823,6 @@ keywordMemoize              = reserved "memoize" keywordCambda               = reserved "cambda" keywordProcedure            = reserved "procedure"-keywordMacro                = reserved "macro" keywordPatternFunction      = reserved "pattern-function" keywordLetRec               = reserved "letrec" keywordLet                  = reserved "let"@@ -885,10 +864,6 @@    <|> (char '+' >> return id)    <|> return id -sign' :: Num a => Parser (a -> a)-sign' = (char '-' >> return negate)-    <|> (char '+' >> return id)- integerLiteral :: Parser Integer integerLiteral = sign <*> P.natural lexer @@ -921,15 +896,6 @@  angles :: Parser a -> Parser a angles = P.angles lexer--colon :: Parser String-colon = P.colon lexer--comma :: Parser String-comma = P.comma lexer--dot :: Parser String-dot = P.dot lexer  ident :: Parser String ident = P.identifier lexer

@@ -1,5 +1,4 @@ {-# LANGUAGE TupleSections    #-}-{-# LANGUAGE MultiWayIf       #-}  {- | Module      : Language.Egison.ParserNonS@@ -25,23 +24,21 @@        , loadFile        ) where -import           Prelude                        hiding (mapM)- import           Control.Applicative            (pure, (*>), (<$>), (<$), (<*), (<*>)) import           Control.Monad.Except           (liftIO, throwError) import           Control.Monad.State            (unless) +import           Data.Char                      (isAsciiUpper, isLetter) import           Data.Functor                   (($>)) import           Data.List                      (find, groupBy)-import           Data.Maybe                     (fromJust, isJust)+import           Data.Maybe                     (fromJust, isJust, isNothing) import           Data.Text                      (pack)-import           Data.Traversable               (mapM)  import           Control.Monad.Combinators.Expr import           Text.Megaparsec import           Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer     as L-import           Text.Megaparsec.Debug          (dbg)+-- import           Text.Megaparsec.Debug          (dbg) import           Text.Megaparsec.Pos            (Pos) import           System.Directory               (doesFileExist, getHomeDirectory) import           System.IO@@ -67,13 +64,13 @@ parseTopExprs = doParse $ many (L.nonIndented sc topExpr) <* eof  parseTopExpr :: String -> Either EgisonError EgisonTopExpr-parseTopExpr = doParse $ sc >> topExpr+parseTopExpr = doParse $ sc >> topExpr <* eof  parseExprs :: String -> Either EgisonError [EgisonExpr] parseExprs = doParse $ many (L.nonIndented sc expr) <* eof  parseExpr :: String -> Either EgisonError EgisonExpr-parseExpr = doParse $ sc >> expr+parseExpr = doParse $ sc >> expr <* eof  -- |Load a libary file loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]@@ -91,7 +88,7 @@   unless doesExist $ throwError $ Default ("file does not exist: " ++ file)   input <- liftIO $ readUTF8File file   exprs <- readTopExprs $ shebang input-  concat <$> mapM  recursiveLoad exprs+  concat <$> mapM recursiveLoad exprs  where   recursiveLoad (Load file)     = loadLibraryFile file   recursiveLoad (LoadFile file) = loadFile file@@ -113,18 +110,18 @@ type Parser = Parsec CustomError String  data CustomError-  = IllFormedPointFreeExpr EgisonBinOp EgisonBinOp+  = IllFormedSection EgisonBinOp EgisonBinOp   | IllFormedDefine   deriving (Eq, Ord)  instance ShowErrorComponent CustomError where-  showErrorComponent (IllFormedPointFreeExpr op op') =+  showErrorComponent (IllFormedSection op op') =     "The operator " ++ info op ++ " must have lower precedence than " ++ info op'     where       info op =          "'" ++ repr op ++ "' [" ++ show (assoc op) ++ " " ++ show (priority op) ++ "]"   showErrorComponent IllFormedDefine =-    "Ill-formed definition syntax."+    "Failed to parse the left hand side of definition expression."   doParse :: Parser a -> String -> Either EgisonError a@@ -143,38 +140,67 @@       <|> defineOrTestExpr       <?> "toplevel expression" +-- Return type of |convertToDefine|.+data ConversionResult+  = Variable Var        -- Definition of a variable with no arguments on lhs.+  | Function Var [Arg]  -- Definition of a function with some arguments on lhs.+  | IndexedVar VarWithIndices+ defineOrTestExpr :: Parser EgisonTopExpr defineOrTestExpr = do   e <- expr-  (do symbol ":="-      body <- expr-      return $ convertToDefine e body)-      <|> return (Test e)+  defineExpr e <|> return (Test e)   where-    -- TODO: Throw IllFormedDefine in pattern match failure.-    -- first 2 cases are the most common ones-    convertToDefine :: EgisonExpr -> EgisonExpr -> EgisonTopExpr-    convertToDefine (VarExpr var) body = Define var body-    convertToDefine (ApplyExpr (VarExpr var) (TupleExpr args)) body =-      Define var (LambdaExpr (map exprToArg args) body)-    convertToDefine e@(BinaryOpExpr op _ _) body-      | repr op == "*" || repr op == "%" =-        case exprToArgs e of-          ScalarArg var : args -> Define (Var [var] []) (LambdaExpr args body)+    defineExpr :: EgisonExpr -> Parser EgisonTopExpr+    defineExpr e = do+      _    <- symbol ":="+      -- When ":=" is observed and the current expression turns out to be a+      -- definition, we do not start over from scratch but re-interpret+      -- what's parsed so far as the lhs of definition.+      case convertToDefine e of+        Nothing -> customFailure IllFormedDefine+        Just (Variable var)      -> Define var <$> expr+        Just (Function var args) -> Define var . LambdaExpr args <$> expr+        Just (IndexedVar var)    -> DefineWithIndices var <$> expr -    exprToArg :: EgisonExpr -> Arg-    exprToArg (VarExpr (Var [x] [])) = ScalarArg x+    convertToDefine :: EgisonExpr -> Maybe ConversionResult+    convertToDefine (VarExpr var) = return $ Variable var+    convertToDefine (ApplyExpr (VarExpr var) (TupleExpr args)) = do+      args' <- mapM ((ScalarArg <$>) . exprToStr) args+      return $ Function var args'+    convertToDefine e@(BinaryOpExpr op _ _)+      | repr op == "*" || repr op == "%" = do+        args <- exprToArgs e+        case args of+          ScalarArg var : args -> return $ Function (Var [var] []) args+          _                    -> Nothing+    convertToDefine (IndexedExpr True (VarExpr (Var var [])) indices) = do+      -- [Index EgisonExpr] -> Maybe [Index String]+      indices' <- mapM (traverse exprToStr) indices+      return $ IndexedVar (VarWithIndices var indices')+    convertToDefine _ = Nothing -    exprToArgs :: EgisonExpr -> [Arg]-    exprToArgs (VarExpr (Var [x] [])) = [ScalarArg x]+    exprToStr :: EgisonExpr -> Maybe String+    exprToStr (VarExpr (Var [x] [])) = Just x+    exprToStr _                      = Nothing++    exprToArgs :: EgisonExpr -> Maybe [Arg]+    exprToArgs (VarExpr (Var [x] [])) = return [ScalarArg x]     exprToArgs (ApplyExpr func (TupleExpr args)) =-      exprToArgs func ++ map exprToArg args-    exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "*" =-      case exprToArgs rhs of-        ScalarArg x : xs -> exprToArgs lhs ++ InvertedScalarArg x : xs-    exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "%" =-      case exprToArgs rhs of-        ScalarArg x : xs -> exprToArgs lhs ++ TensorArg x : xs+      (++) <$> exprToArgs func <*> mapM ((ScalarArg <$>) . exprToStr) args+    exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "*" = do+      lhs' <- exprToArgs lhs+      rhs' <- exprToArgs rhs+      case rhs' of+        ScalarArg x : xs -> return (lhs' ++ InvertedScalarArg x : xs)+        _                -> Nothing+    exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "%" = do+      lhs' <- exprToArgs lhs+      rhs' <- exprToArgs rhs+      case rhs' of+        ScalarArg x : xs -> return (lhs' ++ TensorArg x : xs)+        _                -> Nothing+    exprToArgs _ = Nothing  expr :: Parser EgisonExpr expr = do@@ -201,7 +227,6 @@    <|> algebraicDataMatcherExpr    <|> memoizedLambdaExpr    <|> procedureExpr-   <|> macroExpr    <|> generateTensorExpr    <|> tensorExpr    <|> functionExpr@@ -219,13 +244,14 @@   -- prefixes have top priority   let prefixes = [ [ Prefix (unary "-")                    , Prefix (unary "!") ] ]-      -- Generate binary operator table from reservedBinops+      -- Generate binary operator table from |reservedBinops|       binops = map (map binOpToOperator)         (groupBy (\x y -> priority x == priority y) reservedBinops)    in prefixes ++ binops   where+    -- notFollowedBy (in unary and binary) is necessary for section expression.     unary :: String -> Parser (EgisonExpr -> EgisonExpr)-    unary sym = UnaryOpExpr <$> operator sym+    unary sym = UnaryOpExpr <$> try (operator sym <* notFollowedBy (symbol ")"))      binary :: String -> Parser (EgisonExpr -> EgisonExpr -> EgisonExpr)     binary sym = do@@ -281,9 +307,9 @@       return $ ctor matcher clauses  arg :: Parser Arg-arg = InvertedScalarArg <$> (symbol "*" >> lowerId)-  <|> TensorArg         <$> (symbol "%" >> lowerId)-  <|> ScalarArg         <$> lowerId+arg = InvertedScalarArg <$> (char '*' >> ident)+  <|> TensorArg         <$> (char '%' >> ident)+  <|> ScalarArg         <$> ident   <?> "argument"  letExpr :: Parser EgisonExpr@@ -308,7 +334,7 @@              _  -> (vars, LambdaExpr args body)  withSymbolsExpr :: Parser EgisonExpr-withSymbolsExpr = WithSymbolsExpr <$> (reserved "withSymbols" >> brackets (sepBy lowerId comma)) <*> expr+withSymbolsExpr = WithSymbolsExpr <$> (reserved "withSymbols" >> brackets (sepBy ident comma)) <*> expr  doExpr :: Parser EgisonExpr doExpr = do@@ -332,7 +358,9 @@ matcherExpr = do   reserved "matcher"   pos  <- L.indentLevel-  -- In matcher expression, the first '|' (bar) is indispensable+  -- Assuming it is unlikely that users want to write matchers with only 1+  -- pattern definition, the first '|' (bar) is made indispensable in matcher+  -- expression.   info <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef)   return $ MatcherExpr info   where@@ -367,9 +395,6 @@ procedureExpr :: Parser EgisonExpr procedureExpr = ProcedureExpr <$> (reserved "procedure" >> many lowerId) <*> (symbol "->" >> expr) -macroExpr :: Parser EgisonExpr-macroExpr = MacroExpr <$> (reserved "macro" >> many lowerId) <*> (symbol "->" >> expr)- generateTensorExpr :: Parser EgisonExpr generateTensorExpr = GenerateTensorExpr <$> (reserved "generateTensor" >> atomExpr) <*> atomExpr @@ -393,37 +418,52 @@      elementsExpr = CollectionExpr <$> (sepBy (ElementExpr <$> expr) comma <* symbol "]") +-- Parse an atomic expression starting with '(', which can be:+--   * a tuple+--   * an arbitrary expression wrapped with parenthesis+--   * section tupleOrParenExpr :: Parser EgisonExpr tupleOrParenExpr = do-  elems <- symbol "(" >> try (sepBy expr comma <* symbol ")") <|> (pointFreeExpr <* symbol ")")+  elems <- symbol "(" >> try (sepBy expr comma <* symbol ")") <|> (section <* symbol ")")   case elems of-    [x] -> return x-    _   -> return $ TupleExpr elems+    [x] -> return x                 -- expression wrapped in parenthesis+    _   -> return $ TupleExpr elems -- tuple   where-    pointFreeExpr :: Parser [EgisonExpr]-    pointFreeExpr =-          (do op   <- try . choice $ map (binOpLiteral . repr) reservedBinops-              rarg <- optional expr-              -- TODO(momohatt): Take associativity of operands into account-              case rarg of-                Just (BinaryOpExpr op' _ _) | priority op >= priority op' ->-                  customFailure (IllFormedPointFreeExpr op op')-                _ -> return [makeLambda op Nothing rarg])-      <|> (do larg <- opExpr-              op   <- choice $ map (binOpLiteral . repr) reservedBinops-              case larg of-                BinaryOpExpr op' _ _ | priority op >= priority op' ->-                  customFailure (IllFormedPointFreeExpr op op')-                _ -> return [makeLambda op (Just larg) Nothing])+    section :: Parser [EgisonExpr]+    -- Start from right, in order to parse expressions like (-1 +) correctly+    section = (:[]) <$> (rightSection <|> leftSection) +    -- Sections without the left operand: eg. (+), (+ 1)+    leftSection :: Parser EgisonExpr+    leftSection = do+      op   <- choice $ map (binOpLiteral . repr) reservedBinops+      rarg <- optional expr+      case rarg of+        Just (BinaryOpExpr op' _ _)+          | assoc op' /= RightAssoc && priority op >= priority op' ->+          customFailure (IllFormedSection op op')+        _ -> return (makeLambda op Nothing rarg)++    -- Sections with the left operand but lacks the right operand: eg. (1 +)+    rightSection :: Parser EgisonExpr+    rightSection = do+      larg <- opExpr+      op   <- choice $ map (binOpLiteral . repr) reservedBinops+      case larg of+        BinaryOpExpr op' _ _+          | assoc op' /= LeftAssoc && priority op >= priority op' ->+          customFailure (IllFormedSection op op')+        _ -> return (makeLambda op (Just larg) Nothing)++    -- TODO(momohatt): Generate fresh variable for argument     makeLambda :: EgisonBinOp -> Maybe EgisonExpr -> Maybe EgisonExpr -> EgisonExpr     makeLambda op Nothing Nothing =-      LambdaExpr [ScalarArg ":x", ScalarArg ":y"]+      LambdaExpr [TensorArg ":x", TensorArg ":y"]                  (BinaryOpExpr op (stringToVarExpr ":x") (stringToVarExpr ":y"))     makeLambda op Nothing (Just rarg) =-      LambdaExpr [ScalarArg ":x"] (BinaryOpExpr op (stringToVarExpr ":x") rarg)+      LambdaExpr [TensorArg ":x"] (BinaryOpExpr op (stringToVarExpr ":x") rarg)     makeLambda op (Just larg) Nothing =-      LambdaExpr [ScalarArg ":y"] (BinaryOpExpr op larg (stringToVarExpr ":y"))+      LambdaExpr [TensorArg ":y"] (BinaryOpExpr op larg (stringToVarExpr ":y"))  arrayExpr :: Parser EgisonExpr arrayExpr = ArrayExpr <$> between (symbol "(|") (symbol "|)") (sepEndBy expr comma)@@ -466,35 +506,38 @@              [] -> func              _  -> makeApply func args +-- (Possibly indexed) atomic expressions atomExpr :: Parser EgisonExpr atomExpr = do   e <- atomExpr'+  override <- isNothing <$> optional (try (string "..." <* lookAhead index))   -- TODO(momohatt): "..." (override of index) collides with ContPat   indices <- many index   return $ case indices of              [] -> e-             _  -> IndexedExpr False e indices+             _  -> IndexedExpr override e indices --- atom expr without index+-- Atomic expressions without index atomExpr' :: Parser EgisonExpr-atomExpr' = constantExpr+atomExpr' = partialExpr    -- must come before |constantExpr|+        <|> constantExpr+        <|> FreshVarExpr <$ symbol "#"         <|> VarExpr <$> varLiteral-        <|> inductiveDataOrModuleExpr-        <|> vectorExpr     -- must come before collectionExpr-        <|> arrayExpr      -- must come before tupleOrParenExpr+        <|> vectorExpr     -- must come before |collectionExpr|+        <|> arrayExpr      -- must come before |tupleOrParenExpr|         <|> collectionExpr         <|> tupleOrParenExpr         <|> hashExpr-        <|> QuoteExpr <$> (char '\'' >> atomExpr')+        <|> QuoteExpr <$> (char '\'' >> atomExpr') -- must come after |constantExpr|         <|> QuoteSymbolExpr <$> (char '`' >> atomExpr')+        <|> PartialVarExpr  <$> try (char '%' >> positiveIntegerLiteral)         <?> "atomic expression" -inductiveDataOrModuleExpr :: Parser EgisonExpr-inductiveDataOrModuleExpr = do-  (ident, rest) <- upperOrModuleId-  return $ case rest of-             [] -> InductiveDataExpr ident []-             _  -> VarExpr (Var (ident : rest) [])+partialExpr :: Parser EgisonExpr+partialExpr = do+  n    <- try (L.decimal <* char '#') -- No space after the index+  body <- atomExpr                    -- No space after '#'+  return $ PartialExpr n body  constantExpr :: Parser EgisonExpr constantExpr = numericExpr@@ -573,6 +616,7 @@     (InductivePat x [], _)  -> return $ InductivePat x args     _                       -> error (show (func, args)) +-- (Possibly indexed) atomic pattern atomPattern :: Parser EgisonPattern atomPattern = do   pat     <- atomPattern'@@ -581,7 +625,7 @@              [] -> pat              _  -> IndexedPat pat indices --- atomic pattern without index+-- Atomic pattern without index atomPattern' :: Parser EgisonPattern atomPattern' = WildCard <$   symbol "_"            <|> PatVar   <$> patVarLiteral@@ -636,7 +680,7 @@ -- Tokens -- --- space comsumer+-- Space Comsumer sc :: Parser () sc = L.space space1 lineCmnt blockCmnt   where@@ -668,17 +712,22 @@            <?> "unsigned float"  varLiteral :: Parser Var-varLiteral = stringToVar <$> lowerId+varLiteral = stringToVar <$> ident  patVarLiteral :: Parser Var patVarLiteral = stringToVar <$> (char '$' >> lowerId)  binOpLiteral :: String -> Parser EgisonBinOp-binOpLiteral sym = do-  wedge <- optional (char '!')-  opSym <- operator sym-  let opInfo = fromJust $ find ((== opSym) . repr) reservedBinops-  return $ opInfo { isWedge = isJust wedge }+binOpLiteral sym =+  try (do wedge <- optional (char '!')+          opSym <- operator' sym+          let opInfo = fromJust $ find ((== opSym) . repr) reservedBinops+          return $ opInfo { isWedge = isJust wedge })+   <?> "binary operator"+  where+    -- operator without try+    operator' :: String -> Parser String+    operator' sym = string sym <* notFollowedBy opChar <* sc  reserved :: String -> Parser () reserved w = (lexeme . try) (string w *> notFollowedBy identChar)@@ -692,49 +741,70 @@ patOperator :: String -> Parser String patOperator sym = try $ string sym <* notFollowedBy patOpChar <* sc --- Characters that could consist expression operators.+-- Characters that can consist expression operators. opChar :: Parser Char opChar = oneOf "%^&*-+\\|:<>.?/'!#@$" --- Characters that could consist pattern operators.+-- Characters that can consist pattern operators. -- ! # @ $ are omitted because they can appear at the beginning of atomPattern patOpChar :: Parser Char patOpChar = oneOf "%^&*-+\\|:<>.?/'" --- Characters that consist identifiers+-- Characters that consist identifiers.+-- Note that 'alphaNumChar' can also parse greek letters.+-- TODO(momohatt): Use more natural way to reject "..." identChar :: Parser Char-identChar = alphaNumChar <|> oneOf ['.', '?', '\'', '/']+identChar = alphaNumChar+        <|> oneOf (['?', '\'', '/'] ++ mathSymbols)+        <|> try (char '.' <* notFollowedBy (char '.')) -parens    = between (symbol "(") (symbol ")")-braces    = between (symbol "{") (symbol "}")+-- Non-alphabetical symbols that are allowed for identifiers+mathSymbols :: String+mathSymbols = "∂∇"++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++brackets :: Parser a -> Parser a brackets  = between (symbol "[") (symbol "]")-comma     = symbol "," +comma :: Parser String+comma = symbol ","++-- Notes on identifiers:+-- * Identifiers must be able to include greek letters and some symbols in+--   |mathSymbols|.+-- * Only identifiers starting with capital English letters ('A' - 'Z') can be+--   parsed as |upperId|. Identifiers starting with capital Greek letters must+--   be regarded as |lowerId|.+ lowerId :: Parser String lowerId = (lexeme . try) (p >>= check)   where-    p       = (:) <$> lowerChar <*> many identChar+    p       = (:) <$> satisfy (\c -> c `elem` mathSymbols || isLetter c && not (isAsciiUpper c)) <*> many identChar     check x = if x `elem` lowerReservedWords                 then fail $ "keyword " ++ show x ++ " cannot be an identifier"                 else return x --- TODO: Deprecate BoolExpr and merge it with InductiveDataExpr upperId :: Parser String upperId = (lexeme . try) (p >>= check)   where-    p       = (:) <$> upperChar <*> many alphaNumChar+    p       = (:) <$> satisfy isAsciiUpper <*> many alphaNumChar     check x = if x `elem` upperReservedWords                 then fail $ "keyword " ++ show x ++ " cannot be an identifier"                 else return x --- Parses both InductiveDataExpr and Var with module--- ex. "Greater"       -> ("Greater", [])---     "S.intercalate" -> ("S", ["intercalate"])-upperOrModuleId :: Parser (String, [String])-upperOrModuleId = do-  ident <- (:) <$> upperChar <*> many alphaNumChar-  follows <- many (char '.' >> some alphaNumChar) <* sc-  return (ident, follows)+-- union of lowerId and upperId+ident :: Parser String+ident = (lexeme . try) (p >>= check)+  where+    p       = (:) <$> satisfy (\c -> c `elem` mathSymbols || isLetter c) <*> many identChar+    check x = if x `elem` (lowerReservedWords ++ upperReservedWords)+                then fail $ "keyword " ++ show x ++ " cannot be an identifier"+                else return x  upperReservedWords :: [String] upperReservedWords =@@ -755,7 +825,6 @@   , "memoizedLambda"   , "cambda"   , "procedure"-  , "macro"   , "let"   , "in"   , "where"

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans   #-}  {- | Module      : Language.Egison.PrettyPrint@@ -22,6 +23,7 @@ import qualified Data.Vector               as V  import           Language.Egison.AST+import           Language.Egison.MathExpr import           Language.Egison.Types  --@@ -80,6 +82,14 @@   pretty (MatchAllLambdaExpr matcher clauses) =     pretty "\\matchAll"  <+> prettyMatch matcher clauses +  pretty (MatcherExpr patDefs) =+    pretty "matcher" <> (nest 2 (hardline <> align (vsep (map prettyPatternDef patDefs))))++  pretty (PartialExpr n x) =+    pretty n <> pretty "#" <> pretty x+  pretty (PartialVarExpr n) =+    pretty "%" <> pretty n+   pretty (UnaryOpExpr op x) = pretty op <> pretty x   -- (x1 op' x2) op y   pretty (BinaryOpExpr op x@(BinaryOpExpr op' _ _) y) =@@ -109,11 +119,11 @@  instance Pretty Var where   -- TODO: indices-  pretty (Var xs is) = concatWith (surround dot) (map pretty xs)+  pretty (Var xs _) = concatWith (surround dot) (map pretty xs)  instance Pretty InnerExpr where   pretty (ElementExpr x) = pretty x-  pretty (SubCollectionExpr _) = error "Not supported"+  pretty (SubCollectionExpr _) = pretty "undefined" -- error "(please translate manually)"  instance {-# OVERLAPPING #-} Pretty BindingExpr where   pretty ([var], expr) = pretty var <+> pretty ":=" <+> pretty expr@@ -155,6 +165,9 @@   pretty "as" <+> group (pretty matcher) <+> pretty "with" <>     (nest 2 (hardline <> align (vsep (map pretty clauses)))) +prettyPatternDef :: PatternDef -> Doc ann+prettyPatternDef _ = pretty "undefined"+ listoid :: String -> String -> [Doc ann] -> Doc ann listoid lp rp elems = encloseSep (pretty lp) (pretty rp) (comma <> space) elems @@ -204,9 +217,9 @@   prettyS (ScalarData mExpr) = prettyS mExpr   prettyS (TensorData (Tensor [_] xs js)) = "[| " ++ unwords (map prettyS (V.toList xs)) ++ " |]" ++ concatMap prettyS js   prettyS (TensorData (Tensor [0, 0] _ js)) = "[| [|  |] |]" ++ concatMap prettyS js-  prettyS (TensorData (Tensor [i, j] xs js)) = "[| " ++ f (fromIntegral j) (V.toList xs) ++ "|]" ++ concatMap prettyS js+  prettyS (TensorData (Tensor [_, j] xs js)) = "[| " ++ f (fromIntegral j) (V.toList xs) ++ "|]" ++ concatMap prettyS js    where-    f j [] = ""+    f _ [] = ""     f j xs = "[| " ++ unwords (map prettyS (take j xs)) ++ " |] " ++ f j (drop j xs)   prettyS (TensorData (Tensor ns xs js)) = "(tensor {" ++ unwords (map show ns) ++ "} {" ++ unwords (map prettyS (V.toList xs)) ++ "} )" ++ concatMap prettyS js   prettyS (Float x) = show x@@ -224,14 +237,12 @@   prettyS (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)"   prettyS (CFunc (Just name) _ _ _) = prettyS name   prettyS (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ unwords names ++ "] ...)"-  prettyS (MemoizedFunc (Just name) _ _ _ names _) = prettyS name+  prettyS (MemoizedFunc (Just name) _ _ _ _ _) = prettyS name   prettyS (Proc Nothing _ names _) = "(procedure [" ++ unwords names ++ "] ...)"   prettyS (Proc (Just name) _ _ _) = name-  prettyS (Macro names _) = "(macro [" ++ unwords names ++ "] ...)"   prettyS PatternFunc{} = "#<pattern-function>"   prettyS (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"   prettyS (IOFunc _) = "#<io-function>"-  prettyS (QuotedFunc _) = "#<quoted-function>"   prettyS (Port _) = "#<port>"   prettyS Something = "something"   prettyS Undefined = "undefined"@@ -245,7 +256,7 @@   prettyS = show  instance PrettyS EgisonBinOp where-  prettyS = show+  prettyS = repr  instance PrettyS InnerExpr where   prettyS (ElementExpr e) = prettyS e@@ -281,39 +292,33 @@   prettyS (Symbol _ s js) = s ++ concatMap prettyS js   prettyS (Apply fn mExprs) = "(" ++ prettyS fn ++ " " ++ unwords (map prettyS mExprs) ++ ")"   prettyS (Quote mExprs) = "'" ++ prettyS mExprs-  prettyS (FunctionData Nothing argnames args js) = "(functionData [" ++ unwords (map prettyS argnames) ++ "])" ++ concatMap prettyS js-  prettyS (FunctionData (Just name) argnames args js) = prettyS name ++ concatMap prettyS js+  prettyS (FunctionData name _ _ js) = show name ++ concatMap prettyS js  showTSV :: EgisonValue -> String showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (prettyS val) (map prettyS vals) showTSV (Collection vals) = intercalate "\t" (map prettyS (toList vals)) showTSV val = prettyS val -instance PrettyS (Index EgisonExpr) where-  prettyS (Superscript i)  = "~" ++ prettyS i+instance PrettyS a => PrettyS (Index a) where   prettyS (Subscript i)    = "_" ++ prettyS i-  prettyS (SupSubscript i) = "~_" ++ prettyS i-  prettyS (DFscript _ _)   = ""-  prettyS (Userscript i)   = "|" ++ prettyS i--instance PrettyS (Index ScalarData) where   prettyS (Superscript i)  = "~" ++ prettyS i-  prettyS (Subscript i)    = "_" ++ prettyS i   prettyS (SupSubscript i) = "~_" ++ prettyS i+  prettyS (MultiSubscript x y) = "_[" ++ prettyS x ++ "]..._[" ++ prettyS y ++ "]"+  prettyS (MultiSuperscript x y) = "~[" ++ prettyS x ++ "]...~[" ++ prettyS y ++ "]"   prettyS (DFscript _ _)   = ""   prettyS (Userscript i)   = "|" ++ prettyS i -instance PrettyS (Index EgisonValue) where+instance {-# OVERLAPPING #-} PrettyS (Index EgisonValue) where   prettyS (Superscript i) = case i of-    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "~[" ++ prettyS i ++ "]"+    ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "~[" ++ prettyS i ++ "]"     _ -> "~" ++ prettyS i   prettyS (Subscript i) = case i of-    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ prettyS i ++ "]"+    ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "_[" ++ prettyS i ++ "]"     _ -> "_" ++ prettyS i   prettyS (SupSubscript i) = "~_" ++ prettyS i   prettyS (DFscript i j) = "_d" ++ show i ++ show j   prettyS (Userscript i) = case i of-    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ prettyS i ++ "]"+    ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "_[" ++ prettyS i ++ "]"     _ -> "|" ++ prettyS i  instance PrettyS EgisonPattern where@@ -328,7 +333,6 @@     where varsHelper [] = ""           varsHelper [v] = "$" ++ prettyS v           varsHelper vs = "[" ++ unwords (map (("$" ++) . prettyS) vs) ++ "]"-  prettyS (LaterPat pat) = "(later " ++ prettyS pat ++ ")"   prettyS (NotPat pat) = "!" ++ prettyS pat   prettyS (AndPat pats) = "(&" ++ concatMap ((" " ++) . prettyS) pats ++ ")"   prettyS (OrPat pats) = "(|" ++ concatMap ((" " ++) . prettyS) pats ++ ")"

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase       #-}+{-# LANGUAGE RankNTypes       #-}  {- | Module      : Language.Egison.Primitives@@ -11,12 +12,8 @@  module Language.Egison.Primitives   (-  -- S-syntax version     primitiveEnv   , primitiveEnvNoIO-  -- Non-S syntax (Camel case) version-  , primitiveEnv'-  , primitiveEnvNoIO'   ) where  import           Control.Monad.Except@@ -35,6 +32,7 @@ import qualified Data.Vector               as V  import           Data.Char                 (chr, ord)+import           Data.Text                 (Text) import qualified Data.Text                 as T import qualified Data.Text.IO              as T @@ -47,6 +45,8 @@ import           Language.Egison.Parser import           Language.Egison.Pretty import           Language.Egison.Types+import           Language.Egison.MathExpr+import           Language.Egison.Tensor  primitiveEnv :: IO Env primitiveEnv = do@@ -64,23 +64,6 @@     return (stringToVar name, ref)   return $ extendEnv nullEnv bindings --- primitive env for Non-S syntax-primitiveEnv' :: IO Env-primitiveEnv' = do-  let ops = map (\(name, fn) -> (name, PrimitiveFunc name fn)) (primitives' ++ ioPrimitives')-  bindings <- forM (constants ++ ops) $ \(name, op) -> do-    ref <- newIORef . WHNF $ Value op-    return (stringToVar name, ref)-  return $ extendEnv nullEnv bindings--primitiveEnvNoIO' :: IO Env-primitiveEnvNoIO' = do-  let ops = map (\(name, fn) -> (name, PrimitiveFunc name fn)) primitives'-  bindings <- forM (constants ++ ops) $ \(name, op) -> do-    ref <- newIORef . WHNF $ Value op-    return (stringToVar name, ref)-  return $ extendEnv nullEnv bindings- {-# INLINE noArg #-} noArg :: EgisonM EgisonValue -> PrimitiveFunc noArg f args = do@@ -155,154 +138,46 @@              , ("b.-", minus)              , ("b.*", multiply)              , ("b./", divide)-             , ("b.+'", plus)-             , ("b.-'", minus)-             , ("b.*'", multiply)-             , ("b./'", divide)              , ("f.+", floatBinaryOp (+))              , ("f.-", floatBinaryOp (-))              , ("f.*", floatBinaryOp (*))              , ("f./", floatBinaryOp (/))              , ("numerator", numerator')              , ("denominator", denominator')-             , ("from-math-expr", fromScalarData)-             , ("to-math-expr", toScalarData)-             , ("to-math-expr'", toScalarData)--             , ("modulo",    integerBinaryOp mod)-             , ("quotient",  integerBinaryOp quot)-             , ("remainder", integerBinaryOp rem)-             , ("b.abs", rationalUnaryOp abs)-             , ("b.neg", rationalUnaryOp negate)--             , ("eq?",  eq)-             , ("lt?",  lt)-             , ("lte?", lte)-             , ("gt?",  gt)-             , ("gte?", gte)--             , ("round",    floatToIntegerOp round)-             , ("floor",    floatToIntegerOp floor)-             , ("ceiling",  floatToIntegerOp ceiling)-             , ("truncate", truncate')--             , ("b.sqrt", floatUnaryOp sqrt)-             , ("b.sqrt'", floatUnaryOp sqrt)-             , ("b.exp", floatUnaryOp exp)-             , ("b.log", floatUnaryOp log)-             , ("b.sin", floatUnaryOp sin)-             , ("b.cos", floatUnaryOp cos)-             , ("b.tan", floatUnaryOp tan)-             , ("b.asin", floatUnaryOp asin)-             , ("b.acos", floatUnaryOp acos)-             , ("b.atan", floatUnaryOp atan)-             , ("b.sinh", floatUnaryOp sinh)-             , ("b.cosh", floatUnaryOp cosh)-             , ("b.tanh", floatUnaryOp tanh)-             , ("b.asinh", floatUnaryOp asinh)-             , ("b.acosh", floatUnaryOp acosh)-             , ("b.atanh", floatUnaryOp atanh)--             , ("tensor-size", tensorSize')-             , ("tensor-to-list", tensorToList')-             , ("df-order", dfOrder')--             , ("itof", integerToFloat)-             , ("rtof", rationalToFloat)-             , ("ctoi", charToInteger)-             , ("itoc", integerToChar)--             , ("pack", pack)-             , ("unpack", unpack)-             , ("uncons-string", unconsString)-             , ("length-string", lengthString)-             , ("append-string", appendString)-             , ("split-string", splitString)-             , ("regex", regexString)-             , ("regex-cg", regexStringCaptureGroup)--             , ("add-prime", addPrime)-             , ("add-subscript", addSubscript)-             , ("add-superscript", addSuperscript)--             , ("read-process", readProcess')--             , ("read", read')-             , ("read-tsv", readTSV)-             , ("show", show')-             , ("show-tsv", showTSV')--             , ("empty?", isEmpty')-             , ("uncons", uncons')-             , ("unsnoc", unsnoc')--             , ("bool?", isBool')-             , ("integer?", isInteger')-             , ("rational?", isRational')-             , ("scalar?", isScalar')-             , ("float?", isFloat')-             , ("char?", isChar')-             , ("string?", isString')-             , ("collection?", isCollection')-             , ("array?", isArray')-             , ("hash?", isHash')-             , ("tensor?", isTensor')-             , ("tensor-with-index?", isTensorWithIndex')--             , ("assert", assert)-             , ("assert-equal", assertEqual)-             ]---- for Non-S syntax-primitives' :: [(String, PrimitiveFunc)]-primitives' = [ ("b.+", plus)-             , ("b.-", minus)-             , ("b.*", multiply)-             , ("b./", divide)-             , ("b.+'", plus)-             , ("b.-'", minus)-             , ("b.*'", multiply)-             , ("b./'", divide)-             , ("f.+", floatBinaryOp (+))-             , ("f.-", floatBinaryOp (-))-             , ("f.*", floatBinaryOp (*))-             , ("f./", floatBinaryOp (/))-             , ("numerator", numerator')-             , ("denominator", denominator')              , ("fromMathExpr", fromScalarData)              , ("toMathExpr", toScalarData)              , ("toMathExpr'", toScalarData)               , ("modulo",    integerBinaryOp mod)-             , ("quotient",   integerBinaryOp quot)+             , ("quotient",  integerBinaryOp quot)              , ("remainder", integerBinaryOp rem)              , ("b.abs", rationalUnaryOp abs)              , ("b.neg", rationalUnaryOp negate)               , ("eq?",  eq)-             , ("lt?",  lt)-             , ("lte?", lte)-             , ("gt?",  gt)-             , ("gte?", gte)+             , ("lt?",  scalarCompare (<))+             , ("lte?", scalarCompare (<=))+             , ("gt?",  scalarCompare (>))+             , ("gte?", scalarCompare (>=))               , ("round",    floatToIntegerOp round)              , ("floor",    floatToIntegerOp floor)              , ("ceiling",  floatToIntegerOp ceiling)              , ("truncate", truncate') -             , ("b.sqrt", floatUnaryOp sqrt)+             , ("b.sqrt",  floatUnaryOp sqrt)              , ("b.sqrt'", floatUnaryOp sqrt)-             , ("b.exp", floatUnaryOp exp)-             , ("b.log", floatUnaryOp log)-             , ("b.sin", floatUnaryOp sin)-             , ("b.cos", floatUnaryOp cos)-             , ("b.tan", floatUnaryOp tan)-             , ("b.asin", floatUnaryOp asin)-             , ("b.acos", floatUnaryOp acos)-             , ("b.atan", floatUnaryOp atan)-             , ("b.sinh", floatUnaryOp sinh)-             , ("b.cosh", floatUnaryOp cosh)-             , ("b.tanh", floatUnaryOp tanh)+             , ("b.exp",   floatUnaryOp exp)+             , ("b.log",   floatUnaryOp log)+             , ("b.sin",   floatUnaryOp sin)+             , ("b.cos",   floatUnaryOp cos)+             , ("b.tan",   floatUnaryOp tan)+             , ("b.asin",  floatUnaryOp asin)+             , ("b.acos",  floatUnaryOp acos)+             , ("b.atan",  floatUnaryOp atan)+             , ("b.sinh",  floatUnaryOp sinh)+             , ("b.cosh",  floatUnaryOp cosh)+             , ("b.tanh",  floatUnaryOp tanh)              , ("b.asinh", floatUnaryOp asinh)              , ("b.acosh", floatUnaryOp acosh)              , ("b.atanh", floatUnaryOp atanh)@@ -356,7 +231,8 @@              , ("assert", assert)              , ("assertEqual", assertEqual) -             -- for old library compatibility+             -- for old syntax compatibility+             -- TODO: Delete these after the old syntax is deprecated              , ("from-math-expr", fromScalarData)              , ("to-math-expr", toScalarData)              , ("to-math-expr'", toScalarData)@@ -378,53 +254,28 @@              , ("assert-equal", assertEqual)              ] -rationalUnaryOp :: (Rational -> Rational) -> PrimitiveFunc-rationalUnaryOp op = oneArg $ \val -> do-  r <- fromEgison val-  let r' =  op r-  return $ toEgison r'--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 $ toEgison r''--rationalBinaryPred :: (Rational -> Rational -> Bool) -> PrimitiveFunc-rationalBinaryPred pred = twoArgs $ \val val' -> do-  r <- fromEgison val-  r' <- fromEgison val'-  return $ Bool $ pred r r'+unaryOp :: (EgisonData a, EgisonData b) => (a -> b) -> PrimitiveFunc+unaryOp op = oneArg $ \val -> do+  v <- fromEgison val+  return $ toEgison (op v) -integerBinaryOp :: (Integer -> Integer -> Integer) -> PrimitiveFunc-integerBinaryOp op = twoArgs $ \val val' -> do+binaryOp :: (EgisonData a, EgisonData b) => (a -> a -> b) -> PrimitiveFunc+binaryOp op = twoArgs $ \val val' -> do   i <- fromEgison val   i' <- fromEgison val'   return $ toEgison (op i i') -integerBinaryPred :: (Integer -> Integer -> Bool) -> PrimitiveFunc-integerBinaryPred pred = twoArgs $ \val val' -> do-  i <- fromEgison val-  i' <- fromEgison val'-  return $ Bool $ pred i i'+rationalUnaryOp :: (Rational -> Rational) -> PrimitiveFunc+rationalUnaryOp = unaryOp +integerBinaryOp :: (Integer -> Integer -> Integer) -> PrimitiveFunc+integerBinaryOp = binaryOp+ floatUnaryOp :: (Double -> Double) -> PrimitiveFunc-floatUnaryOp op = oneArg $ \val -> case val of-                                     (Float f) -> return $ Float (op f)-                                     _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack+floatUnaryOp = unaryOp  floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc-floatBinaryOp op = twoArgs $ \val val' -> case (val, val') of-                                            (Float f, Float f') -> return $ Float (op f f')-                                            _ -> throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack--floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc-floatBinaryPred pred = twoArgs $ \val val' -> do-  f <- fromEgison val-  f' <- fromEgison val'-  return $ Bool $ pred f f'-+floatBinaryOp = binaryOp  -- -- Arith@@ -479,53 +330,17 @@ eq = twoArgs' $ \val val' ->   return $ Bool $ val == val' -lt :: PrimitiveFunc-lt = twoArgs' $ \val val' -> scalarBinaryPred' val val'- where-  scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do-    r <- fromEgison m :: EgisonM Rational-    r' <- fromEgison n :: EgisonM Rational-    return $ Bool $ (<) r r'-  scalarBinaryPred' (Float f)      (Float f') = return $ Bool (f < f')-  scalarBinaryPred' (ScalarData _) val        = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack-  scalarBinaryPred' (Float _)      val        = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack-  scalarBinaryPred' val            _          = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack--lte :: PrimitiveFunc-lte = twoArgs' $ \val val' -> scalarBinaryPred' val val'- where-  scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do-    r <- fromEgison m :: EgisonM Rational-    r' <- fromEgison n :: EgisonM Rational-    return $ Bool $ (<=) r r'-  scalarBinaryPred' (Float f)      (Float f') = return $ Bool (f <= f')-  scalarBinaryPred' (ScalarData _) val        = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack-  scalarBinaryPred' (Float _)      val        = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack-  scalarBinaryPred' val            _          = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack--gt :: PrimitiveFunc-gt = twoArgs' $ \val val' -> scalarBinaryPred' val val'- where-  scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do-    r <- fromEgison m :: EgisonM Rational-    r' <- fromEgison n :: EgisonM Rational-    return $ Bool $ (>) r r'-  scalarBinaryPred' (Float f)      (Float f')  = return $ Bool $ (f > f')-  scalarBinaryPred' (ScalarData _) val         = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack-  scalarBinaryPred' (Float _)      val         = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack-  scalarBinaryPred' val            _           = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack--gte :: PrimitiveFunc-gte = twoArgs' $ \val val' -> scalarBinaryPred' val val'- where-  scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do-    r <- fromEgison m :: EgisonM Rational-    r' <- fromEgison n :: EgisonM Rational-    return $ Bool $ (>=) r r'-  scalarBinaryPred' (Float f)      (Float f')  = return $ Bool (f >= f')-  scalarBinaryPred' (ScalarData _) val         = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack-  scalarBinaryPred' (Float _)      val         = throwError =<< TypeMismatch "float"  (Value val) <$> getFuncNameStack-  scalarBinaryPred' val            _           = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack+scalarCompare :: (forall a. Ord a => a -> a -> Bool) -> PrimitiveFunc+scalarCompare cmp = twoArgs' $ \val1 val2 ->+  case (val1, val2) of+    (ScalarData _, ScalarData _) -> do+      r1 <- fromEgison val1 :: EgisonM Rational+      r2 <- fromEgison val2 :: EgisonM Rational+      return $ Bool (cmp r1 r2)+    (Float f1, Float f2) -> return $ Bool (cmp f1 f2)+    (ScalarData _, _) -> throwError =<< TypeMismatch "number" (Value val2) <$> getFuncNameStack+    (Float _,      _) -> throwError =<< TypeMismatch "float"  (Value val2) <$> getFuncNameStack+    _                 -> throwError =<< TypeMismatch "number" (Value val1) <$> getFuncNameStack  truncate' :: PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val@@ -560,38 +375,30 @@ -- -- Transform ---numberToFloat' :: EgisonValue -> EgisonValue-numberToFloat' (ScalarData (Div (Plus []) _)) = Float 0-numberToFloat' (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = Float $ fromRational (x % y)- integerToFloat :: PrimitiveFunc integerToFloat = rationalToFloat  rationalToFloat :: PrimitiveFunc rationalToFloat = oneArg $ \val ->   case val of-    (ScalarData (Div (Plus []) _)) -> return $ numberToFloat' val-    (ScalarData (Div (Plus [Term _ []]) (Plus [Term _ []]))) -> return $ numberToFloat' val+    (ScalarData (Div (Plus []) _)) -> return $ Float 0+    (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) -> return $ Float (fromRational (x % y))     _ -> throwError =<< TypeMismatch "integer or rational number" (Value val) <$> getFuncNameStack  charToInteger :: PrimitiveFunc-charToInteger = oneArg $ \val -> case val of-                                   Char c -> do-                                     let i = fromIntegral $ ord c :: Integer-                                     return $ toEgison i-                                   _ -> throwError =<< TypeMismatch "character" (Value val) <$> getFuncNameStack+charToInteger = unaryOp ctoi+  where+    ctoi :: Char -> Integer+    ctoi = fromIntegral . ord  integerToChar :: PrimitiveFunc-integerToChar = oneArg $ \val -> case val of-                                   (ScalarData _) -> do-                                      i <- fromEgison val :: EgisonM Integer-                                      return $ Char $ chr $ fromIntegral i-                                   _ -> throwError =<< TypeMismatch "integer" (Value val) <$> getFuncNameStack+integerToChar = unaryOp itoc+  where+    itoc :: Integer -> Char+    itoc = chr . fromIntegral  floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc-floatToIntegerOp op = oneArg $ \val -> do-  f <- fromEgison val-  return $ toEgison (op f)+floatToIntegerOp = unaryOp  -- -- String@@ -600,54 +407,53 @@ pack = oneArg $ \val -> do   str <- packStringValue val   return $ String str+  where+    packStringValue :: EgisonValue -> EgisonM Text+    packStringValue (Collection seq) = do+      let ls = toList seq+      str <- mapM fromEgison ls+      return $ T.pack str+    packStringValue (Tuple [val]) = packStringValue val+    packStringValue val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack  unpack :: PrimitiveFunc-unpack = oneArg $ \val -> case val of-                            String str -> return $ toEgison (T.unpack str)-                            _ -> throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack+unpack = unaryOp T.unpack  unconsString :: PrimitiveFunc-unconsString = oneArg $ \val -> case val of-                                  String str -> case T.uncons str of-                                                  Just (c, rest) ->  return $ Tuple [Char c, String rest]-                                                  Nothing -> throwError $ Default "Tried to unsnoc empty string"-                                  _ -> throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack+unconsString = oneArg $ \val -> do+  str <- fromEgison val+  case T.uncons str of+    Just (c, rest) -> return $ Tuple [Char c, String rest]+    Nothing -> throwError $ Default "Tried to unsnoc empty string"  lengthString :: PrimitiveFunc-lengthString = oneArg $ \val -> case val of-                                  String str -> return . toEgison . toInteger $ T.length str-                                  _ -> throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack+lengthString = unaryOp (toInteger . T.length)  appendString :: PrimitiveFunc-appendString = twoArgs $ \val1 val2 -> case (val1, val2) of-                                         (String str1, String str2) -> return . String $ T.append str1 str2-                                         (String _, _) -> throwError =<< TypeMismatch "string" (Value val2) <$> getFuncNameStack-                                         (_, _) -> throwError =<< TypeMismatch "string" (Value val1) <$> getFuncNameStack+appendString = binaryOp T.append  splitString :: PrimitiveFunc-splitString = twoArgs $ \pat src -> case (pat, src) of-                                      (String patStr, String srcStr) -> return . Collection . Sq.fromList $ map String $ T.splitOn patStr srcStr-                                      (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack-                                      (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack+splitString = twoArgs $ \pat src -> do+  patStr <- fromEgison pat+  srcStr <- fromEgison src+  return . Collection . Sq.fromList $ map String $ T.splitOn patStr srcStr  regexString :: PrimitiveFunc-regexString = twoArgs $ \pat src -> case (pat, src) of-                                      (String patStr, String srcStr) ->-                                        case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe (String, String, String)) of-                                          Nothing -> return . Collection . Sq.fromList $ []-                                          Just (a,b,c) -> return . Collection . Sq.fromList $ [Tuple [String $ T.pack a, String $ T.pack b, String $ T.pack c]]-                                      (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack-                                      (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack+regexString = twoArgs $ \pat src -> do+  patStr <- fromEgison pat+  srcStr <- fromEgison src+  case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe (String, String, String)) of+    Nothing -> return . Collection . Sq.fromList $ []+    Just (a,b,c) -> return . Collection . Sq.fromList $ [Tuple [String $ T.pack a, String $ T.pack b, String $ T.pack c]]  regexStringCaptureGroup :: PrimitiveFunc-regexStringCaptureGroup = twoArgs $ \pat src -> case (pat, src) of-                                                  (String patStr, String srcStr) ->-                                                    case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe [[String]]) of-                                                      Nothing -> return . Collection . Sq.fromList $ []-                                                      Just ((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) <$> getFuncNameStack-                                                  (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack+regexStringCaptureGroup = twoArgs $ \pat src -> do+  patStr <- fromEgison pat+  srcStr <- fromEgison src+  case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe [[String]]) of+    Nothing -> return . Collection . Sq.fromList $ []+    Just ((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)]]  --regexStringMatch :: PrimitiveFunc --regexStringMatch = twoArgs $ \pat src -> do@@ -657,47 +463,63 @@ --    (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack  addPrime :: PrimitiveFunc-addPrime = oneArg $ \sym -> case sym of-                              ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id (name ++ "'") is, 1)]]) (Plus [Term 1 []])))-                              _ -> throwError =<< TypeMismatch "symbol" (Value sym) <$> getFuncNameStack+addPrime = oneArg $ \sym ->+  case sym of+    ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])) ->+      return (ScalarData (Div (Plus [Term 1 [(Symbol id (name ++ "'") is, 1)]]) (Plus [Term 1 []])))+    _ -> throwError =<< TypeMismatch "symbol" (Value sym) <$> getFuncNameStack  addSubscript :: PrimitiveFunc-addSubscript = twoArgs $ \fn sub -> case (fn, sub) of-                                      (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),-                                       ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []])))-                                      (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),-                                       ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []])))-                                      (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])),-                                       _) -> throwError =<< TypeMismatch "symbol or integer" (Value sub) <$> getFuncNameStack-                                      _ -> throwError =<< TypeMismatch "symbol or integer" (Value fn) <$> getFuncNameStack+addSubscript = twoArgs $ \fn sub ->+  case (fn, sub) of+    (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),+     ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) ->+       return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []])))+    (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),+     ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) ->+       return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []])))+    (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])),+     _) -> throwError =<< TypeMismatch "symbol or integer" (Value sub) <$> getFuncNameStack+    _ -> throwError =<< TypeMismatch "symbol or integer" (Value fn) <$> getFuncNameStack  addSuperscript :: PrimitiveFunc-addSuperscript = twoArgs $ \fn sub -> case (fn, sub) of-                                        (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),-                                         ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []])))-                                        (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),-                                         ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []])))-                                        (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])),-                                         _) -> throwError =<< TypeMismatch "symbol" (Value sub) <$> getFuncNameStack-                                        _ -> throwError =<< TypeMismatch "symbol" (Value fn) <$> getFuncNameStack+addSuperscript = twoArgs $ \fn sub ->+  case (fn, sub) of+    (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),+     ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) ->+       return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []])))+    (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])),+     ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) ->+       return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []])))+    (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])),+     _) -> throwError =<< TypeMismatch "symbol" (Value sub) <$> getFuncNameStack+    _ -> throwError =<< TypeMismatch "symbol" (Value fn) <$> getFuncNameStack  readProcess' :: PrimitiveFunc-readProcess' = threeArgs' $ \cmd args input -> case (cmd, args, input) of-                                                 (String cmdStr, Collection argStrs, String inputStr) -> do-                                                   outputStr <- liftIO $ readProcess (T.unpack cmdStr) (map (\case-                                                                                                                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])) <$> getFuncNameStack+readProcess' = threeArgs' $ \cmd args input ->+  case (cmd, args, input) of+    (String cmdStr, Collection argStrs, String inputStr) -> do+      let cmd' = T.unpack cmdStr+      let args' = map (\case String argStr -> T.unpack argStr) (toList argStrs)+      let input' = T.unpack inputStr+      outputStr <- liftIO $ readProcess cmd' args' input'+      return (String (T.pack outputStr))+    (_, _, _) -> throwError =<< TypeMismatch "(string, collection, string)" (Value (Tuple [cmd, args, input])) <$> getFuncNameStack  read' :: PrimitiveFunc-read'= oneArg' $ \val -> fromEgison val >>= readExpr . T.unpack >>= evalExprDeep nullEnv+read'= oneArg' $ \val -> do+  str <- fromEgison val+  ast <- readExpr (T.unpack str)+  evalExprDeep nullEnv ast  readTSV :: PrimitiveFunc-readTSV= oneArg' $ \val -> do rets <- fromEgison val >>= readExprs . T.unpack >>= mapM (evalExprDeep nullEnv)-                              case rets of-                                [ret] -> return ret-                                _     -> return (Tuple rets)+readTSV= oneArg' $ \val -> do+  str   <- fromEgison val+  exprs <- readExprs (T.unpack str)+  rets  <- mapM (evalExprDeep nullEnv) exprs+  case rets of+    [ret] -> return ret+    _     -> return (Tuple rets)  show' :: PrimitiveFunc show'= oneArg' $ \val -> return $ toEgison $ T.pack $ show val@@ -709,11 +531,7 @@ -- Collection -- isEmpty' :: PrimitiveFunc-isEmpty' whnf = do-  b <- isEmptyCollection whnf-  if b-    then return $ Value $ Bool True-    else return $ Value $ Bool False+isEmpty' whnf = Value . Bool <$> isEmptyCollection whnf  uncons' :: PrimitiveFunc uncons' whnf = do@@ -739,10 +557,11 @@     else throwError =<< Assertion (show label) <$> getFuncNameStack  assertEqual :: PrimitiveFunc-assertEqual = threeArgs' $ \label actual expected -> if actual == expected-                                                       then return $ Bool True-                                                       else throwError =<< Assertion-                                                         (show label ++ "\n expected: " ++ show expected ++ "\n but found: " ++ show actual) <$> getFuncNameStack+assertEqual = threeArgs' $ \label actual expected ->+  if actual == expected+     then return $ Bool True+     else throwError =<< Assertion+       (show label ++ "\n expected: " ++ show expected ++ "\n but found: " ++ show actual) <$> getFuncNameStack  -- -- IO Primitives@@ -750,34 +569,6 @@  ioPrimitives :: [(String, PrimitiveFunc)] ioPrimitives = [ ("return", return')-               , ("open-input-file", makePort ReadMode)-               , ("open-output-file", makePort WriteMode)-               , ("close-input-port", closePort)-               , ("close-output-port", closePort)-               , ("read-char", readChar)-               , ("read-line", readLine)-               , ("write-char", writeChar)-               , ("write", writeString)--               , ("read-char-from-port", readCharFromPort)-               , ("read-line-from-port", readLineFromPort)-               , ("write-char-to-port", writeCharToPort)-               , ("write-to-port", writeStringToPort)--               , ("eof?", isEOFStdin)-               , ("flush", flushStdout)-               , ("eof-port?", isEOFPort)-               , ("flush-port", flushPort)-               , ("read-file", readFile')--               , ("rand", randRange)-               , ("f.rand", randRangeDouble)---               , ("sqlite", sqlite)-               ]---- For Non-S syntax-ioPrimitives' :: [(String, PrimitiveFunc)]-ioPrimitives' = [ ("return", return')                , ("openInputFile", makePort ReadMode)                , ("openOutputFile", makePort WriteMode)                , ("closeInputPort", closePort)@@ -801,7 +592,8 @@                , ("rand", randRange)                , ("f.rand", randRangeDouble) -               -- for S-expression library compatibility+               -- for old syntax compatibility+               -- TODO: Delete these after the old syntax is deprecated                , ("open-input-file", makePort ReadMode)                , ("open-output-file", makePort WriteMode)                , ("close-input-port", closePort)

@@ -0,0 +1,440 @@+{- |+Module      : Language.Egison.Tensor+Copyright   : Satoshi Egi+Licence     : MIT++This module contains functions for tensors.+-}++module Language.Egison.Tensor+    (+    -- * Tensor+      initTensor+    , tSize+    , tToList+    , tIndex+    , tref+    , enumTensorIndices+    , changeIndexList+    , tTranspose+    , tTranspose'+    , tFlipIndices+    , appendDFscripts+    , removeDFscripts+    , tMap+    , tMap2+    , tMapN+    , tSum+    , tProduct+    , tContract+    , tContract'+    , tConcat+    , tConcat'+    ) where++import           Prelude                   hiding (foldr, mappend, mconcat)++import           Control.Monad.Except+import qualified Data.Vector               as V+import           Data.List                 (any, delete, elem, find, findIndex,+                                            partition, splitAt, (\\))++import           Language.Egison.AST+import           Language.Egison.MathExpr+import           Language.Egison.Types++--+-- Tensors+--++initTensor :: [Integer] -> [a] -> [EgisonValue] -> [EgisonValue] -> Tensor a+initTensor ns xs sup sub = Tensor ns (V.fromList xs) (map Superscript sup ++ map Subscript sub)++tSize :: Tensor a -> [Integer]+tSize (Tensor ns _ _) = ns+tSize (Scalar _)      = []++tToList :: Tensor a -> [a]+tToList (Tensor _ xs _) = V.toList xs+tToList (Scalar x)      = [x]++tToVector :: Tensor a -> V.Vector a+tToVector (Tensor _ xs _) = xs+tToVector (Scalar x)      = V.fromList [x]++tIndex :: Tensor a -> [Index EgisonValue]+tIndex (Tensor _ _ js) = js+tIndex (Scalar _)      = []++tIntRef' :: HasTensor a => Integer -> Tensor a -> EgisonM a+tIntRef' i (Tensor [n] xs _) =+  if 0 < i && i <= n+     then fromTensor $ Scalar $ xs V.! fromIntegral (i - 1)+     else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack+tIntRef' i (Tensor (n:ns) xs js) =+  if 0 < i && i <= n+   then let w = fromIntegral (product ns) in+        let ys = V.take w (V.drop (w * fromIntegral (i - 1)) xs) in+          fromTensor $ Tensor ns ys (cdr js)+   else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack+tIntRef' _ _ = throwError $ Default "More indices than the order of the tensor"++tIntRef :: HasTensor a => [Integer] -> Tensor a -> EgisonM (Tensor a)+tIntRef [] (Tensor [] xs _)+  | V.length xs == 1 = return $ Scalar (xs V.! 0)+  | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack+tIntRef [] t = return t+tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms++tref :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM a+tref [] (Tensor [] xs _)+  | V.length xs == 1 = fromTensor $ Scalar (xs V.! 0)+  | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack+tref [] t = fromTensor t+tref (Subscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref (Subscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms+tref (Superscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref (Superscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms+tref (SupSubscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref (SupSubscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms+tref (Subscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do+  m <- fromEgison mVal+  n <- fromEgison nVal+  if m > n+    then+      fromTensor (Tensor (replicate (length is) 0) V.empty [])+    else do+      ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n]+      symId <- fresh+      tConcat (Subscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor+tref (Superscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do+  m <- fromEgison mVal+  n <- fromEgison nVal+  if m > n+    then+      fromTensor (Tensor (replicate (length is) 0) V.empty [])+    else do+      ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n]+      symId <- fresh+      tConcat (Superscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor+tref (SupSubscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do+  m <- fromEgison mVal+  n <- fromEgison nVal+  if m > n+    then+      fromTensor (Tensor (replicate (length is) 0) V.empty [])+    else do+      ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n]+      symId <- fresh+      tConcat (SupSubscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor+tref (s:ms) (Tensor (_:ns) xs js) = do+  let yss = split (product ns) xs+  ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss+  mapM toTensor ts >>= tConcat s >>= fromTensor+tref _ _ = throwError $ Default "More indices than the order of the tensor"++-- Enumarates all indices (1-indexed) from shape+-- ex.+-- >>> enumTensorIndices [2,2,2]+-- [[1,1,1],[1,1,2],[1,2,1],[1,2,2],[2,1,1],[2,1,2],[2,2,1],[2,2,2]]+enumTensorIndices :: [Integer] -> [[Integer]]+enumTensorIndices [] = [[]]+enumTensorIndices (n:ns) = concatMap (\i -> map (i:) (enumTensorIndices ns)) [1..n]++changeIndexList :: [Index String] -> [EgisonValue] -> [Index String]+changeIndexList idxlist ms = map (\(i, m) -> case i of+                                              Superscript s -> Superscript (s ++ m)+                                              Subscript s -> Subscript (s ++ m)) $ zip idxlist (map show ms)++transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> [Integer] -> EgisonM [Integer]+transIndex [] [] is = return is+transIndex (j1:js1) js2 is = do+  let (hjs2, tjs2) = break (\j2 -> j1 == j2) js2+  if null tjs2+    then throwError =<< InconsistentTensorIndex <$> getFuncNameStack+    else do let n = length hjs2 + 1+            rs <- transIndex js1 (hjs2 ++ tail tjs2) (take (n - 1) is ++ drop n is)+            return (nth (fromIntegral n) is:rs)+transIndex _ _ _ = throwError =<< InconsistentTensorSize <$> getFuncNameStack++tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM (Tensor a)+tTranspose is t@(Tensor ns _ js) = do+  ns' <- transIndex js is ns+  xs' <- V.fromList <$> mapM (transIndex js is) (enumTensorIndices ns') >>= mapM (`tIntRef` t) >>= mapM fromTensor+  return $ Tensor ns' xs' is++tTranspose' :: HasTensor a => [EgisonValue] -> Tensor a -> EgisonM (Tensor a)+tTranspose' is t@(Tensor _ _ js) = do+  is' <- g is js+  tTranspose is' t+ where+  f :: Index EgisonValue -> EgisonValue+  f (Subscript i)    = i+  f (Superscript i)  = i+  f (SupSubscript i) = i+  g :: [EgisonValue] -> [Index EgisonValue] -> EgisonM [Index EgisonValue]+  g [] _ = return []+  g (i:is) js = case find (\j -> i == f j) js of+                  Nothing ->  throwError =<< InconsistentTensorIndex <$> getFuncNameStack+                  Just j' -> do js' <- g is js+                                return $ j':js'++tFlipIndices :: HasTensor a => Tensor a -> EgisonM (Tensor a)+tFlipIndices (Tensor ns xs js) = return $ Tensor ns xs (map flipIndex js)+ where+  flipIndex (Subscript i)   = Superscript i+  flipIndex (Superscript i) = Subscript i+  flipIndex x               = x++appendDFscripts :: Integer -> WHNFData -> EgisonM WHNFData+appendDFscripts id (Intermediate (ITensor (Tensor s xs is))) = do+  let k = fromIntegral (length s - length is)+  return $ Intermediate (ITensor (Tensor s xs (is ++ map (DFscript id) [1..k])))+appendDFscripts id (Value (TensorData (Tensor s xs is))) = do+  let k = fromIntegral (length s - length is)+  return $ Value (TensorData (Tensor s xs (is ++ map (DFscript id) [1..k])))+appendDFscripts _ whnf = return whnf++removeDFscripts :: WHNFData -> EgisonM WHNFData+removeDFscripts (Intermediate (ITensor (Tensor s xs is))) = do+  let (ds, js) = partition isDF is+  Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is)+  return (Intermediate (ITensor (Tensor s ys js)))+ where+  isDF (DFscript _ _) = True+  isDF _              = False+removeDFscripts (Value (TensorData (Tensor s xs is))) = do+  let (ds, js) = partition isDF is+  Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is)+  return (Value (TensorData (Tensor s ys js)))+ where+  isDF (DFscript _ _) = True+  isDF _              = False+removeDFscripts whnf = return whnf++tMap :: HasTensor a => (a -> EgisonM a) -> Tensor a -> EgisonM (Tensor a)+tMap f (Tensor ns xs js') = do+  let k = fromIntegral $ length ns - length js'+  let js = js' ++ map (DFscript 0) [1..k]+  xs' <- V.fromList <$> mapM f (V.toList xs)+  t <- toTensor (V.head xs')+  case t of+    Tensor ns1 _ js1' -> do+      let k1 = fromIntegral $ length ns1 - length js1'+      let js1 = js1' ++ map (DFscript 0) [1..k1]+      tContract' $ Tensor (ns ++ ns1) (V.concat (V.toList (V.map tensorElems xs'))) (js ++ js1)+    _ -> return $ Tensor ns xs' js+tMap f (Scalar x) = Scalar <$> f x++tMapN :: HasTensor a => ([a] -> EgisonM a) -> [Tensor a] -> EgisonM (Tensor a)+tMapN f ts@(Tensor ns _ js : _) = do+  xs' <- mapM (\is -> mapM (tIntRef is) ts >>= mapM fromTensor >>= f) (enumTensorIndices ns)+  return $ Tensor ns (V.fromList xs') js+tMapN f xs = Scalar <$> (mapM fromTensor xs >>= f)++tMap2 :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)+tMap2 f (Tensor ns1 xs1 js1') (Tensor ns2 xs2 js2') = do+  let k1 = fromIntegral $ length ns1 - length js1'+  let js1 = js1' ++ map (DFscript 0) [1..k1]+  let k2 = fromIntegral $ length ns2 - length js2'+  let js2 = js2' ++ map (DFscript 0) [1..k2]+  let (cjs, tjs1, tjs2) = h js1 js2+  t1' <- tTranspose (cjs ++ tjs1) (Tensor ns1 xs1 js1)+  t2' <- tTranspose (cjs ++ tjs2) (Tensor ns2 xs2 js2)+  let cns = take (length cjs) (tSize t1')+  rts1 <- mapM (`tIntRef` t1') (enumTensorIndices cns)+  rts2 <- mapM (`tIntRef` t2') (enumTensorIndices cns)+  rts' <- zipWithM (tProduct f) rts1 rts2+  let ret = Tensor (cns ++ tSize (head rts')) (V.concat (map tToVector rts')) (cjs ++ tIndex (head rts'))+  tTranspose (uniq (tDiagIndex (js1 ++ js2))) ret+ where+  h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue])+  h js1 js2 = let cjs = filter (`elem` js2) js1 in+                (cjs, js1 \\ cjs, js2 \\ cjs)+  uniq :: [Index EgisonValue] -> [Index EgisonValue]+  uniq []     = []+  uniq (x:xs) = x:uniq (delete x xs)+tMap2 f t@Tensor{} (Scalar x) = tMap (`f` x) t+tMap2 f (Scalar x) t@Tensor{} = tMap (f x) t+tMap2 f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2++tDiag :: HasTensor a => Tensor a -> EgisonM (Tensor a)+tDiag t@(Tensor _ _ js) =+  case filter (\j -> any (p j) js) js of+    [] -> return t+    xs -> do+      let ys = js \\ (xs ++ map rev xs)+      t2 <- tTranspose (xs ++ map rev xs ++ ys) t+      let (ns1, tmp) = splitAt (length xs) (tSize t2)+      let (_, ns2) = splitAt (length xs) tmp+      ts <- mapM (\is -> tIntRef (is ++ is) t2) (enumTensorIndices ns1)+      return $ Tensor (ns1 ++ ns2) (V.concat (map tToVector ts)) (map g xs ++ ys)+ where+  p :: Index EgisonValue -> Index EgisonValue -> Bool+  p (Superscript i) (Subscript j) = i == j+  p (Subscript _) _               = False+  p _ _                           = False+  rev :: Index EgisonValue -> Index EgisonValue+  rev (Superscript i) = Subscript i+  rev (Subscript i)   = Superscript i+  g :: Index EgisonValue -> Index EgisonValue+  g (Superscript i) = SupSubscript i+  g (Subscript i)   = SupSubscript i+tDiag t = return t++tDiagIndex :: [Index EgisonValue] -> [Index EgisonValue]+tDiagIndex js =+  let xs = filter (\j -> any (p j) js) js in+  let ys = js \\ (xs ++ map rev xs) in+    map g xs ++ ys+ where+  p :: Index EgisonValue -> Index EgisonValue -> Bool+  p (Superscript i) (Subscript j) = i == j+  p (Subscript _) _               = False+  p _ _                           = False+  rev :: Index EgisonValue -> Index EgisonValue+  rev (Superscript i) = Subscript i+  rev (Subscript i)   = Superscript i+  g :: Index EgisonValue -> Index EgisonValue+  g (Superscript i) = SupSubscript i+  g (Subscript i)   = SupSubscript i++tSum :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)+tSum f (Tensor ns1 xs1 js1) t2@Tensor{} = do+  t2' <- tTranspose js1 t2+  case t2' of+    (Tensor ns2 xs2 _)+      | ns2 == ns1 -> do ys <- V.mapM (uncurry f) (V.zip xs1 xs2)+                         return (Tensor ns1 ys js1)+      | otherwise -> throwError =<< InconsistentTensorSize <$> getFuncNameStack++tProduct :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)+tProduct f (Tensor ns1 xs1 js1') (Tensor ns2 xs2 js2') = do+  let k1 = fromIntegral $ length ns1 - length js1'+  let js1 = js1' ++ map (DFscript 0) [1..k1]+  let k2 = fromIntegral $ length ns2 - length js2'+  let js2 = js2' ++ map (DFscript 0) [1..k2]+  let (cjs1, cjs2, tjs1, tjs2) = h js1 js2+  let t1 = Tensor ns1 xs1 js1+  let t2 = Tensor ns2 xs2 js2+  case cjs1 of+    [] -> do+      xs' <- V.fromList <$> mapM (\is -> do+                              let is1 = take (length ns1) is+                              let is2 = take (length ns2) (drop (length ns1) is)+                              x1 <- tIntRef is1 t1 >>= fromTensor+                              x2 <- tIntRef is2 t2 >>= fromTensor+                              f x1 x2) (enumTensorIndices (ns1 ++ ns2))+      tContract' (Tensor (ns1 ++ ns2) xs' (js1 ++ js2))+    _ -> do+      t1' <- tTranspose (cjs1 ++ tjs1) t1+      t2' <- tTranspose (cjs2 ++ tjs2) t2+      let (cns1, _) = splitAt (length cjs1) (tSize t1')+      rts' <- mapM (\is -> do rt1 <- tIntRef is t1'+                              rt2 <- tIntRef is t2'+                              tProduct f rt1 rt2) (enumTensorIndices cns1)+      let ret = Tensor (cns1 ++ tSize (head rts')) (V.concat (map tToVector rts')) (map g cjs1 ++ tIndex (head rts'))+      tTranspose (uniq (map g cjs1 ++ tjs1 ++ tjs2)) ret+ where+  h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue], [Index EgisonValue])+  h js1 js2 = let cjs = filter (\j -> any (p j) js2) js1 in+                (cjs, map rev cjs, js1 \\ cjs, js2 \\ map rev cjs)+  p :: Index EgisonValue -> Index EgisonValue -> Bool+  p (Superscript i) (Subscript j) = i == j+  p (Subscript i) (Superscript j) = i == j+  p _ _                           = False+  rev :: Index EgisonValue -> Index EgisonValue+  rev (Superscript i) = Subscript i+  rev (Subscript i)   = Superscript i+  g :: Index EgisonValue -> Index EgisonValue+  g (Superscript i) = SupSubscript i+  g (Subscript i)   = SupSubscript i+  uniq :: [Index EgisonValue] -> [Index EgisonValue]+  uniq []     = []+  uniq (x:xs) = x:uniq (delete x xs)+tProduct f (Scalar x) (Tensor ns xs js) = do+  xs' <- V.mapM (f x) xs+  return $ Tensor ns xs' js+tProduct f (Tensor ns xs js) (Scalar x) = do+  xs' <- V.mapM (`f` x) xs+  return $ Tensor ns xs' js+tProduct f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2++tContract :: HasTensor a => Tensor a -> EgisonM [Tensor a]+tContract t = do+  t' <- tDiag t+  case t' of+    (Tensor (n:_) _ (SupSubscript _ : _)) -> do+      ts <- mapM (`tIntRef'` t') [1..n]+      tss <- mapM toTensor ts >>= mapM tContract+      return $ concat tss+    _ -> return [t']++tContract' :: HasTensor a => Tensor a -> EgisonM (Tensor a)+tContract' t@(Tensor ns _ js) =+  case findPairs p js of+    [] -> return t+    (m,n):_ -> do+      let (hjs, mjs, tjs) = removePairs (m,n) js+      xs' <- mapM (\i -> tref (hjs ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ mjs+                                    ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ tjs) t)+                  [1..(ns !! m)]+      mapM toTensor xs' >>= tConcat (js !! m) >>= tTranspose (hjs ++ [js !! m] ++ mjs ++ tjs) >>= tContract'+ where+  p :: Index EgisonValue -> Index EgisonValue -> Bool+  p (Superscript i) (Superscript j)   = i == j+  p (Subscript i) (Subscript j)       = i == j+  p (DFscript i1 j1) (DFscript i2 j2) = (i1 == i2) && (j1 == j2)+  p _ _                               = False+tContract' val = return val++tConcat :: HasTensor a => Index EgisonValue -> [Tensor a] -> EgisonM (Tensor a)+tConcat s (Tensor ns@(0:_) _ js:_) = return $ Tensor (0:ns) V.empty (s:js)+tConcat s ts@(Tensor ns _ js:_) = return $ Tensor (fromIntegral (length ts):ns) (V.concat (map tToVector ts)) (s:js)+tConcat s ts = do+  ts' <- mapM getScalar ts+  return $ Tensor [fromIntegral (length ts)] (V.fromList ts') [s]++tConcat' :: HasTensor a => [Tensor a] -> EgisonM (Tensor a)+tConcat' (Tensor ns@(0:_) _ _ : _) = return $ Tensor (0:ns) V.empty []+tConcat' ts@(Tensor ns _ _ : _) = return $ Tensor (fromIntegral (length ts):ns) (V.concat (map tToVector ts)) []+tConcat' ts = do+  ts' <- mapM getScalar ts+  return $ Tensor [fromIntegral (length ts)] (V.fromList ts') []+++-- utility functions for tensors++nth :: Integer -> [a] -> a+nth i xs = xs !! fromIntegral (i - 1)++cdr :: [a] -> [a]+cdr []     = []+cdr (_:ts) = ts++split :: Integer -> V.Vector a -> [V.Vector a]+split w xs+ | V.null xs = []+ | otherwise = let (hs, ts) = V.splitAt (fromIntegral w) xs in+                 hs:split w ts++getScalar :: Tensor a -> EgisonM a+getScalar (Scalar x) = return x+getScalar _          = throwError $ Default "Inconsitent Tensor order"++findPairs :: (a -> a -> Bool) -> [a] -> [(Int, Int)]+findPairs p xs = reverse $ findPairs' 0 p xs++findPairs' :: Int -> (a -> a -> Bool) -> [a] -> [(Int, Int)]+findPairs' _ _ [] = []+findPairs' m p (x:xs) = case findIndex (p x) xs of+                    Just i  -> (m, m + i + 1):findPairs' (m + 1) p xs+                    Nothing -> findPairs' (m + 1) p xs++removePairs :: (Int, Int) -> [a] -> ([a],[a],[a])+removePairs (m, n) xs =          -- (0,1) [i i]+  let (hms, tts) = splitAt n xs  -- [i] [i]+      ts = tail tts              -- []+      (hs, tms) = splitAt m hms  -- [] [i]+      ms = tail tms              -- []+   in (hs, ms, ts)               -- [] [] []

@@ -19,52 +19,17 @@       EgisonValue (..)     , Matcher     , PrimitiveFunc-    , ScalarData (..)-    , PolyExpr (..)-    , TermExpr (..)-    , SymbolExpr (..)+    , EgisonHashKey (..)     , EgisonData (..)     , Tensor (..)     , HasTensor (..)-    -- * Tensor-    , initTensor-    , tSize-    , tToList-    , tIndex-    , tref-    , enumTensorIndices-    , changeIndexList-    , tTranspose-    , tTranspose'-    , tFlipIndices-    , appendDFscripts-    , removeDFscripts-    , tMap-    , tMap2-    , tMapN-    , tSum-    , tProduct-    , tContract-    , tContract'-    , tConcat-    , tConcat'     -- * Scalar     , symbolScalarData+    , symbolScalarData'     , getSymId     , getSymName     , mathExprToEgison     , egisonToScalarData-    , mathNormalize'-    , mathFold-    , mathSymbolFold-    , mathTermFold-    , mathRemoveZero-    , mathDivide-    , mathPlus-    , mathMult-    , mathNegate-    , mathNumerator-    , mathDenominator     , extractScalar     , extractScalar'     -- * Internal data@@ -76,12 +41,10 @@     , EgisonWHNF (..)     -- * Environment     , Env (..)-    , VarWithIndices (..)     , Binding     , nullEnv     , extendEnv     , refVar-    , varToVarWithIndices     -- * Pattern matching     , Match     , MatchingTree (..)@@ -159,9 +122,7 @@ import qualified Data.Sequence             as Sq import qualified Data.Vector               as V -import           Data.List                 (any, delete, elem, elemIndex, find,-                                            findIndex, intercalate, partition,-                                            splitAt, (\\))+import           Data.List                 (intercalate) import           Data.Text                 (Text)  import           Data.Ratio@@ -170,6 +131,7 @@ import           System.IO.Unsafe          (unsafePerformIO)  import           Language.Egison.AST+import           Language.Egison.MathExpr  -- -- Values@@ -196,11 +158,9 @@   | CFunc (Maybe Var) Env String EgisonExpr   | MemoizedFunc (Maybe Var) ObjectRef (IORef (HashMap [Integer] ObjectRef)) Env [String] EgisonExpr   | Proc (Maybe String) Env [String] EgisonExpr-  | Macro [String] EgisonExpr   | PatternFunc Env [String] EgisonPattern   | PrimitiveFunc String PrimitiveFunc   | IOFunc (EgisonM WHNFData)-  | QuotedFunc EgisonValue   | Port Handle   | Something   | Undefined@@ -210,60 +170,15 @@  type PrimitiveFunc = WHNFData -> EgisonM WHNFData +data EgisonHashKey =+    IntKey Integer+  | CharKey Char+  | StrKey Text+ -- -- Scalar and Tensor Types -- -data ScalarData =-    Div PolyExpr PolyExpr- deriving (Eq)--newtype PolyExpr =-    Plus [TermExpr]--data TermExpr =-    Term Integer [(SymbolExpr, Integer)]--data SymbolExpr =-    Symbol Id String [Index ScalarData]-  | Apply EgisonValue [ScalarData]-  | Quote ScalarData-  | FunctionData (Maybe EgisonValue) [EgisonValue] [EgisonValue] [Index ScalarData] -- fnname argnames args indices- deriving (Eq)--type Id = String--instance Eq PolyExpr where-  (Plus []) == (Plus []) = True-  (Plus (x:xs)) == (Plus ys) =-    case elemIndex x ys of-      Just i -> let (hs, _:ts) = splitAt i ys in-                  Plus xs == Plus (hs ++ ts)-      Nothing -> False-  _ == _ = False--instance Eq TermExpr where-  (Term a []) == (Term b []) = a == b-  (Term a ((Quote x, n):xs)) == (Term b ys)-    | (a /= b) && (a /= negate b) = False-    | otherwise = case elemIndex (Quote x, n) ys of-                    Just i -> let (hs, _:ts) = splitAt i ys in-                                Term a xs == Term b (hs ++ ts)-                    Nothing -> case elemIndex (Quote (mathNegate x), n) ys of-                                 Just i -> let (hs, _:ts) = splitAt i ys in-                                             if even n-                                               then Term a xs == Term b (hs ++ ts)-                                               else Term (negate a) xs == Term b (hs ++ ts)-                                 Nothing -> False-  (Term a (x:xs)) == (Term b ys)-    | (a /= b) && (a /= negate b) = False-    | otherwise = case elemIndex x ys of-                    Just i -> let (hs, _:ts) = splitAt i ys in-                                Term a xs == Term b (hs ++ ts)-                    Nothing -> False-  _ == _ = False-- data Tensor a =     Tensor [Integer] (V.Vector a) [Index EgisonValue]   | Scalar a@@ -304,11 +219,14 @@ symbolScalarData :: String -> String -> EgisonValue symbolScalarData id name = ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []])) +symbolScalarData' :: String -> String -> ScalarData+symbolScalarData' id name = Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []])+ getSymId :: EgisonValue -> String-getSymId (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []]))) = id+getSymId (ScalarData (Div (Plus [Term 1 [(Symbol id _ [], 1)]]) (Plus [Term 1 []]))) = id  getSymName :: EgisonValue -> String-getSymName (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []]))) = name+getSymName (ScalarData (Div (Plus [Term 1 [(Symbol _ name [], 1)]]) (Plus [Term 1 []]))) = name  mathExprToEgison :: ScalarData -> EgisonValue mathExprToEgison (Div p1 p2) = InductiveData "Div" [polyExprToEgison p1, polyExprToEgison p2]@@ -327,12 +245,10 @@                                           Subscript k -> InductiveData "Sub" [ScalarData k]                                           Userscript k -> InductiveData "User" [ScalarData k]                                       ) js))-symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n]+symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [ScalarData fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n] symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n] symbolExprToEgison (FunctionData name argnames args js, n) =-  case name of-    Nothing -> Tuple [InductiveData "Function" [symbolScalarData "" "", Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n]-    Just name' -> Tuple [InductiveData "Function" [name', Collection (Sq.fromList argnames), Collection (Sq.fromList args), f js], toEgison n]+  Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData argnames)), Collection (Sq.fromList (map ScalarData args)), f js], toEgison n]  where   f js = Collection (Sq.fromList (map (\case                                           Superscript k -> InductiveData "Sup" [ScalarData k]@@ -382,14 +298,18 @@     (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []]))) ->       return (Symbol id name js', n') egisonToSymbolExpr (Tuple [InductiveData "Apply" [fn, Collection mExprs], n]) = do+  fn' <- extractScalar fn   mExprs' <- mapM egisonToScalarData (toList mExprs)   n' <- fromEgison n-  return (Apply fn mExprs', n')+  return (Apply fn' mExprs', n') egisonToSymbolExpr (Tuple [InductiveData "Quote" [mExpr], n]) = do   mExpr' <- egisonToScalarData mExpr   n' <- fromEgison n   return (Quote mExpr', n') egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection argnames, Collection args, Collection seq], n]) = do+  name' <- extractScalar name+  argnames' <- mapM extractScalar (toList argnames)+  args' <- mapM extractScalar (toList args)   let js = toList seq   js' <- mapM (\j -> case j of                          InductiveData "Sup" [ScalarData k] -> return (Superscript k)@@ -398,181 +318,10 @@                          _ -> throwError =<< TypeMismatch "math symbol expression" (Value j) <$> getFuncNameStack                ) js   n' <- fromEgison n-  let name' = case getSymName name of-                "" -> Nothing-                s  -> Just name-  return (FunctionData name' (toList argnames) (toList args) js', n')+  return (FunctionData name' argnames' args' js', n') egisonToSymbolExpr val = throwError =<< TypeMismatch "math symbol expression" (Value val) <$> getFuncNameStack -mathNormalize' :: ScalarData -> ScalarData-mathNormalize' mExpr = mathDivide (mathRemoveZero (mathFold (mathRemoveZeroSymbol mExpr)))--termsGcd :: [TermExpr] -> TermExpr-termsGcd (t:ts) = f t ts- where-  f :: TermExpr -> [TermExpr] -> TermExpr-  f ret [] =  ret-  f (Term a xs) (Term b ys:ts) =-    f (Term (gcd a b) (g xs ys)) ts-  g :: [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)]-  g [] ys = []-  g ((x, n):xs) ys = let (z, m) = h (x, n) ys in-    if m == 0 then g xs ys else (z, m):g xs ys-  h :: (SymbolExpr, Integer) -> [(SymbolExpr, Integer)] -> (SymbolExpr, Integer)-  h (x, n) [] = (x, 0)-  h (Quote x, n) ((Quote y, m):ys)-    | x == y = (Quote x, min n m)-    | x == mathNegate y = (Quote x, min n m)-    | otherwise = h (Quote x, n) ys-  h (x, n) ((y, m):ys) = if x == y-                         then (x, min n m)-                         else h (x, n) ys--mathDivide :: ScalarData -> ScalarData-mathDivide (Div (Plus ts1) (Plus [])) = Div (Plus ts1) (Plus [])-mathDivide (Div (Plus []) (Plus ts2)) = Div (Plus []) (Plus ts2)-mathDivide (Div (Plus ts1) (Plus ts2)) =-  let z = termsGcd (ts1 ++ ts2) in-  case z of-    (Term c zs) -> case ts2 of-      [Term a _] -> if a < 0-                      then Div (Plus (map (`mathDivideTerm` Term (-1 * c) zs) ts1)) (Plus (map (`mathDivideTerm` Term (-1 * c) zs) ts2))-                      else Div (Plus (map (`mathDivideTerm` z) ts1)) (Plus (map (`mathDivideTerm` z) ts2))-      _ -> Div (Plus (map (`mathDivideTerm` z) ts1)) (Plus (map (`mathDivideTerm` z) ts2))--mathDivideTerm :: TermExpr -> TermExpr -> TermExpr-mathDivideTerm (Term a xs) (Term b ys) =-  let (sgn, zs) = f 1 xs ys in-  Term (sgn * div a b) zs- where-  f :: Integer -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Integer, [(SymbolExpr, Integer)])-  f sgn xs [] = (sgn, xs)-  f sgn xs ((y, n):ys) =-    let (sgns, zs) = unzip (map (\(x, m) -> g (x, m) (y, n)) xs) in-    f (sgn * product sgns) zs ys-  g :: (SymbolExpr, Integer) -> (SymbolExpr, Integer) -> (Integer, (SymbolExpr, Integer))-  g (Quote x, n) (Quote y, m)-    | x == y = (1, (Quote x, n - m))-    | x == mathNegate y = if even m then (1, (Quote x, n - m)) else (-1, (Quote x, n - m))-    | otherwise = (1, (Quote x, n))-  g (x, n) (y, m) =-    if x == y-    then (1, (x, n - m))-    else (1, (x, n))--mathRemoveZeroSymbol :: ScalarData -> ScalarData-mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) =-  let p x = case x of-              (_, 0) -> False-              _      -> True in-  let ts1' = map (\(Term a xs) -> Term a (filter p xs)) ts1 in-  let ts2' = map (\(Term a xs) -> Term a (filter p xs)) ts2 in-    Div (Plus ts1') (Plus ts2')--mathRemoveZero :: ScalarData -> ScalarData-mathRemoveZero (Div (Plus ts1) (Plus ts2)) =-  let ts1' = filter (\(Term a _) -> a /= 0) ts1 in-  let ts2' = filter (\(Term a _) -> a /= 0) ts2 in-    case ts1' of-      [] -> Div (Plus []) (Plus [Term 1 []])-      _  -> Div (Plus ts1') (Plus ts2')--mathFold :: ScalarData -> ScalarData-mathFold mExpr = mathTermFold (mathSymbolFold (mathTermFold mExpr))--mathSymbolFold :: ScalarData -> ScalarData-mathSymbolFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (map f ts1)) (Plus (map f ts2))- where-  f :: TermExpr -> TermExpr-  f (Term a xs) = let (ys, sgns) = unzip $ g [] xs-                    in Term (product sgns * a) ys-  g :: [((SymbolExpr, Integer),Integer)] -> [(SymbolExpr, Integer)] -> [((SymbolExpr, Integer),Integer)]-  g ret [] = ret-  g ret ((x, n):xs) =-    if any (p (x, n)) ret-      then g (map (h (x, n)) ret) xs-      else g (ret ++ [((x, n), 1)]) xs-  p :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> Bool-  p (Quote x, _) ((Quote y, _),_) = (x == y) || (mathNegate x == y)-  p (x, _) ((y, _),_)             = x == y-  h :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> ((SymbolExpr, Integer), Integer)-  h (Quote x, n) ((Quote y, m), sgn)-    | x == y = ((Quote y, m + n), sgn)-    | x == mathNegate y = if even n then ((Quote y, m + n), sgn) else ((Quote y, m + n), -1 * sgn)-    | otherwise = ((Quote y, m), sgn)-  h (x, n) ((y, m), sgn) = if x == y-                             then ((y, m + n), sgn)-                             else ((y, m), sgn)--mathTermFold :: ScalarData -> ScalarData-mathTermFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (f ts1)) (Plus (f ts2))- where-  f :: [TermExpr] -> [TermExpr]-  f = f' []-  f' :: [TermExpr] -> [TermExpr] -> [TermExpr]-  f' ret [] = ret-  f' ret (Term a xs:ts) =-    if any (\(Term _ ys) -> fst (p 1 xs ys)) ret-      then f' (map (g (Term a xs)) ret) ts-      else f' (ret ++ [Term a xs]) ts-  g :: TermExpr -> TermExpr -> TermExpr-  g (Term a xs) (Term b ys) = let (c, sgn) = p 1 xs ys in-                                if c-                                  then Term ((sgn * a) + b) ys-                                  else Term b ys-  p :: Integer -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Bool, Integer)-  p sgn [] [] = (True, sgn)-  p sgn [] _ = (False, 0)-  p sgn ((x, n):xs) ys =-    let (b, ys', sgn2) = q (x, n) [] ys in-      if b-        then p (sgn * sgn2) xs ys'-        else (False, 0)-  q :: (SymbolExpr, Integer) -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Bool, [(SymbolExpr, Integer)], Integer)-  q _ _ [] = (False, [], 1)-  q (Quote x, n) ret ((Quote y, m):ys)-    | (x == y) && (n == m) = (True, ret ++ ys, 1)-    | (mathNegate x == y) && (n == m) = if even n then (True, ret ++ ys, 1) else (True, ret ++ ys, -1)-    | otherwise = q (Quote x, n) (ret ++ [(Quote y, m)]) ys-  q (Quote x, n) ret ((y,m):ys) = q (Quote x, n) (ret ++ [(y, m)]) ys-  q (x, n) ret ((y, m):ys) = if (x == y) && (n == m)-                               then (True, ret ++ ys, 1)-                               else q (x, n) (ret ++ [(y, m)]) ys- -----  Arithmetic operations-----mathPlus :: ScalarData -> ScalarData -> ScalarData-mathPlus (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathPlusPoly (mathMultPoly m1 n2) (mathMultPoly m2 n1)) (mathMultPoly n1 n2)--mathPlusPoly :: PolyExpr -> PolyExpr -> PolyExpr-mathPlusPoly (Plus ts1) (Plus ts2) = Plus (ts1 ++ ts2)--mathMult :: ScalarData -> ScalarData -> ScalarData-mathMult (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathMultPoly m1 m2) (mathMultPoly n1 n2)--mathMult' :: ScalarData -> ScalarData -> ScalarData-mathMult' (Div m1 n1) (Div m2 n2) = Div (mathMultPoly m1 m2) (mathMultPoly n1 n2)--mathMultPoly :: PolyExpr -> PolyExpr -> PolyExpr-mathMultPoly (Plus []) (Plus _) = Plus []-mathMultPoly (Plus _) (Plus []) = Plus []-mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> Plus (map (\(Term b ys) -> Term (a * b) (xs ++ ys)) ts2)) ts1)--mathNegate :: ScalarData -> ScalarData-mathNegate (Div m n) = Div (mathNegate' m) n--mathNegate' :: PolyExpr -> PolyExpr-mathNegate' (Plus ts) = Plus (map (\(Term a xs) -> Term (negate a) xs) ts)--mathNumerator :: ScalarData -> ScalarData-mathNumerator (Div m _) = Div m (Plus [Term 1 []])--mathDenominator :: ScalarData -> ScalarData-mathDenominator (Div _ n) = Div n (Plus [Term 1 []])---- -- ExtractScalar -- @@ -585,407 +334,8 @@ extractScalar' val = throwError =<< TypeMismatch "integer or string" val <$> getFuncNameStack  ----- Tensors ----initTensor :: [Integer] -> [a] -> [EgisonValue] -> [EgisonValue] -> Tensor a-initTensor ns xs sup sub = Tensor ns (V.fromList xs) (map Superscript sup ++ map Subscript sub)--tSize :: Tensor a -> [Integer]-tSize (Tensor ns _ _) = ns-tSize (Scalar _)      = []--tToList :: Tensor a -> [a]-tToList (Tensor _ xs _) = V.toList xs-tToList (Scalar x)      = [x]--tToVector :: Tensor a -> V.Vector a-tToVector (Tensor _ xs _) = xs-tToVector (Scalar x)      = V.fromList [x]--tIndex :: Tensor a -> [Index EgisonValue]-tIndex (Tensor _ _ js) = js-tIndex (Scalar _)      = []--tIntRef' :: HasTensor a => Integer -> Tensor a -> EgisonM a-tIntRef' i (Tensor [n] xs _) =-  if (0 < i) && (i <= n)-     then fromTensor $ Scalar $ xs V.! fromIntegral (i - 1)-     else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack-tIntRef' i (Tensor (n:ns) xs js) =-  if (0 < i) && (i <= n)-   then let w = fromIntegral (product ns) in-        let ys = V.take w (V.drop (w * fromIntegral (i - 1)) xs) in-          fromTensor $ Tensor ns ys (cdr js)-   else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack-tIntRef' i _ = throwError $ Default "More indices than the order of the tensor"--tIntRef :: HasTensor a => [Integer] -> Tensor a -> EgisonM (Tensor a)-tIntRef [] (Tensor [] xs _)-  | V.length xs == 1 = return $ Scalar (xs V.! 0)-  | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack-tIntRef [] t = return t-tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms--tref :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM a-tref [] (Tensor [] xs _)-  | V.length xs == 1 = fromTensor $ Scalar (xs V.! 0)-  | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack-tref [] t = fromTensor t-tref (Subscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms-tref (Subscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms-tref (Superscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms-tref (Superscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms-tref (SupSubscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms-tref (SupSubscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms-tref (Subscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do-  m <- fromEgison mVal-  n <- fromEgison nVal-  if m > n-    then-      fromTensor (Tensor (replicate (length is) 0) V.empty [])-    else do-      ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n]-      symId <- fresh-      tConcat (Subscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor-tref (Superscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do-  m <- fromEgison mVal-  n <- fromEgison nVal-  if m > n-    then-      fromTensor (Tensor (replicate (length is) 0) V.empty [])-    else do-      ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n]-      symId <- fresh-      tConcat (Superscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor-tref (SupSubscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do-  m <- fromEgison mVal-  n <- fromEgison nVal-  if m > n-    then-      fromTensor (Tensor (replicate (length is) 0) V.empty [])-    else do-      ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n]-      symId <- fresh-      tConcat (SupSubscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor-tref (s:ms) (Tensor (n:ns) xs js) = do-  let yss = split (product ns) xs-  ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss-  mapM toTensor ts >>= tConcat s >>= fromTensor-tref _ t = throwError $ Default "More indices than the order of the tensor"--enumTensorIndices :: [Integer] -> [[Integer]]-enumTensorIndices [] = [[]]-enumTensorIndices (n:ns) = concatMap (\i -> map (i:) (enumTensorIndices ns)) [1..n]--changeIndexList :: [Index String] -> [EgisonValue] -> [Index String]-changeIndexList idxlist ms = map (\(i, m) -> case i of-                                              Superscript s -> Superscript (s ++ m)-                                              Subscript s -> Subscript (s ++ m)) $ zip idxlist (map show ms)--transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> [Integer] -> EgisonM [Integer]-transIndex [] [] is = return is-transIndex (j1:js1) js2 is = do-  let (hjs2, tjs2) = break (\j2 -> j1 == j2) js2-  if null tjs2-    then throwError =<< InconsistentTensorIndex <$> getFuncNameStack-    else do let n = length hjs2 + 1-            rs <- transIndex js1 (hjs2 ++ tail tjs2) (take (n - 1) is ++ drop n is)-            return (nth (fromIntegral n) is:rs)-transIndex _ _ _ = throwError =<< InconsistentTensorSize <$> getFuncNameStack--tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM (Tensor a)-tTranspose is t@(Tensor ns xs js) = do-  ns' <- transIndex js is ns-  xs' <- V.fromList <$> mapM (transIndex js is) (enumTensorIndices ns') >>= mapM (`tIntRef` t) >>= mapM fromTensor-  return $ Tensor ns' xs' is--tTranspose' :: HasTensor a => [EgisonValue] -> Tensor a -> EgisonM (Tensor a)-tTranspose' is t@(Tensor ns xs js) = do-  is' <- g is js-  tTranspose is' t- where-  f :: Index EgisonValue -> EgisonValue-  f (Subscript i)    = i-  f (Superscript i)  = i-  f (SupSubscript i) = i-  g :: [EgisonValue] -> [Index EgisonValue] -> EgisonM [Index EgisonValue]-  g [] js = return []-  g (i:is) js = case find (\j -> i == f j) js of-                  Nothing ->  throwError =<< InconsistentTensorIndex <$> getFuncNameStack-                  (Just j') -> do js' <- g is js-                                  return $ j':js'--tFlipIndices :: HasTensor a => Tensor a -> EgisonM (Tensor a)-tFlipIndices (Tensor ns xs js) = return $ Tensor ns xs (map flipIndex js)- where-  flipIndex (Subscript i)   = Superscript i-  flipIndex (Superscript i) = Subscript i-  flipIndex x               = x--appendDFscripts :: Integer -> WHNFData -> EgisonM WHNFData-appendDFscripts id (Intermediate (ITensor (Tensor s xs is))) = do-  let k = fromIntegral (length s - length is)-  return $ Intermediate (ITensor (Tensor s xs (is ++ map (DFscript id) [1..k])))-appendDFscripts id (Value (TensorData (Tensor s xs is))) = do-  let k = fromIntegral (length s - length is)-  return $ Value (TensorData (Tensor s xs (is ++ map (DFscript id) [1..k])))-appendDFscripts _ whnf = return whnf--removeDFscripts :: WHNFData -> EgisonM WHNFData-removeDFscripts (Intermediate (ITensor (Tensor s xs is))) = do-  let (ds, js) = partition isDF is-  (Tensor s ys _) <- tTranspose (js ++ ds) (Tensor s xs is)-  return (Intermediate (ITensor (Tensor s ys js)))- where-  isDF (DFscript _ _) = True-  isDF _              = False-removeDFscripts (Value (TensorData (Tensor s xs is))) = do-  let (ds, js) = partition isDF is-  (Tensor s ys _) <- tTranspose (js ++ ds) (Tensor s xs is)-  return (Value (TensorData (Tensor s ys js)))- where-  isDF (DFscript _ _) = True-  isDF _              = False-removeDFscripts whnf = return whnf--tMap :: HasTensor a => (a -> EgisonM a) -> Tensor a -> EgisonM (Tensor a)-tMap f (Tensor ns xs js') = do-  let k = fromIntegral $ length ns - length js'-  let js = js' ++ map (DFscript 0) [1..k]-  xs' <- V.fromList <$> mapM f (V.toList xs)-  t <- toTensor (V.head xs')-  case t of-    (Tensor ns1 _ js1') -> do-      let k1 = fromIntegral $ length ns1 - length js1'-      let js1 = js1' ++ map (DFscript 0) [1..k1]-      tContract' $ Tensor (ns ++ ns1) (V.concat (V.toList (V.map tensorElems xs'))) (js ++ js1)-    _ -> return $ Tensor ns xs' js-tMap f (Scalar x) = Scalar <$> f x--tMapN :: HasTensor a => ([a] -> EgisonM a) -> [Tensor a] -> EgisonM (Tensor a)-tMapN f ts@(Tensor ns xs js:_) = do-  xs' <- mapM (\is -> mapM (tIntRef is) ts >>= mapM fromTensor >>= f) (enumTensorIndices ns)-  return $ Tensor ns (V.fromList xs') js-tMapN f xs = Scalar <$> (mapM fromTensor xs >>= f)--tMap2 :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)-tMap2 f t1@(Tensor ns1 xs1 js1') t2@(Tensor ns2 xs2 js2') = do-  let k1 = fromIntegral $ length ns1 - length js1'-  let js1 = js1' ++ map (DFscript 0) [1..k1]-  let k2 = fromIntegral $ length ns2 - length js2'-  let js2 = js2' ++ map (DFscript 0) [1..k2]-  let (cjs, tjs1, tjs2) = h js1 js2-  t1' <- tTranspose (cjs ++ tjs1) (Tensor ns1 xs1 js1)-  t2' <- tTranspose (cjs ++ tjs2) (Tensor ns2 xs2 js2)-  let cns = take (length cjs) (tSize t1')-  rts1 <- mapM (`tIntRef` t1') (enumTensorIndices cns)-  rts2 <- mapM (`tIntRef` t2') (enumTensorIndices cns)-  rts' <- zipWithM (tProduct f) rts1 rts2-  let ret = Tensor (cns ++ tSize (head rts')) (V.concat (map tToVector rts')) (cjs ++ tIndex (head rts'))-  tTranspose (uniq (tDiagIndex (js1 ++ js2))) ret- where-  h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue])-  h js1 js2 = let cjs = filter (`elem` js2) js1 in-                (cjs, js1 \\ cjs, js2 \\ cjs)-  uniq :: [Index EgisonValue] -> [Index EgisonValue]-  uniq []     = []-  uniq (x:xs) = x:uniq (delete x xs)-tMap2 f t@Tensor{} (Scalar x) = tMap (`f` x) t-tMap2 f (Scalar x) t@Tensor{} = tMap (f x) t-tMap2 f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2--tDiag :: HasTensor a => Tensor a -> EgisonM (Tensor a)-tDiag t@(Tensor _ _ js) =-  case filter (\j -> any (p j) js) js of-    [] -> return t-    xs -> do-      let ys = js \\ (xs ++ map rev xs)-      t2 <- tTranspose (xs ++ map rev xs ++ ys) t-      let (ns1, tmp) = splitAt (length xs) (tSize t2)-      let (_, ns2) = splitAt (length xs) tmp-      ts <- mapM (\is -> tIntRef (is ++ is) t2) (enumTensorIndices ns1)-      return $ Tensor (ns1 ++ ns2) (V.concat (map tToVector ts)) (map g xs ++ ys)- where-  p :: Index EgisonValue -> Index EgisonValue -> Bool-  p (Superscript i) (Subscript j) = i == j-  p (Subscript i) _               = False-  p _ _                           = False-  rev :: Index EgisonValue -> Index EgisonValue-  rev (Superscript i) = Subscript i-  rev (Subscript i)   = Superscript i-  g :: Index EgisonValue -> Index EgisonValue-  g (Superscript i) = SupSubscript i-  g (Subscript i)   = SupSubscript i-tDiag t = return t--tDiagIndex :: [Index EgisonValue] -> [Index EgisonValue]-tDiagIndex js =-  let xs = filter (\j -> any (p j) js) js in-  let ys = js \\ (xs ++ map rev xs) in-    map g xs ++ ys- where-  p :: Index EgisonValue -> Index EgisonValue -> Bool-  p (Superscript i) (Subscript j) = i == j-  p (Subscript _) _               = False-  p _ _                           = False-  rev :: Index EgisonValue -> Index EgisonValue-  rev (Superscript i) = Subscript i-  rev (Subscript i)   = Superscript i-  g :: Index EgisonValue -> Index EgisonValue-  g (Superscript i) = SupSubscript i-  g (Subscript i)   = SupSubscript i--tSum :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)-tSum f t1@(Tensor ns1 xs1 js1) t2@Tensor{} = do-  t2' <- tTranspose js1 t2-  case t2' of-    (Tensor ns2 xs2 _)-      | ns2 == ns1 -> do ys <- V.mapM (uncurry f) (V.zip xs1 xs2)-                         return (Tensor ns1 ys js1)-      | otherwise -> throwError =<< InconsistentTensorSize <$> getFuncNameStack--tProduct :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a)-tProduct f t1''@(Tensor ns1 xs1 js1') t2''@(Tensor ns2 xs2 js2') = do-  let k1 = fromIntegral $ length ns1 - length js1'-  let js1 = js1' ++ map (DFscript 0) [1..k1]-  let k2 = fromIntegral $ length ns2 - length js2'-  let js2 = js2' ++ map (DFscript 0) [1..k2]-  let (cjs1, cjs2, tjs1, tjs2) = h js1 js2-  let t1 = Tensor ns1 xs1 js1-  let t2 = Tensor ns2 xs2 js2-  case cjs1 of-    [] -> do-      xs' <- V.fromList <$> mapM (\is -> do-                              let is1 = take (length ns1) is-                              let is2 = take (length ns2) (drop (length ns1) is)-                              x1 <- tIntRef is1 t1 >>= fromTensor-                              x2 <- tIntRef is2 t2 >>= fromTensor-                              f x1 x2) (enumTensorIndices (ns1 ++ ns2))-      tContract' (Tensor (ns1 ++ ns2) xs' (js1 ++ js2))-    _ -> do-      t1' <- tTranspose (cjs1 ++ tjs1) t1-      t2' <- tTranspose (cjs2 ++ tjs2) t2-      let (cns1, tns1) = splitAt (length cjs1) (tSize t1')-      let (cns2, tns2) = splitAt (length cjs2) (tSize t2')-      rts' <- mapM (\is -> do rt1 <- tIntRef is t1'-                              rt2 <- tIntRef is t2'-                              tProduct f rt1 rt2) (enumTensorIndices cns1)-      let ret = Tensor (cns1 ++ tSize (head rts')) (V.concat (map tToVector rts')) (map g cjs1 ++ tIndex (head rts'))-      tTranspose (uniq (map g cjs1 ++ tjs1 ++ tjs2)) ret- where-  h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue], [Index EgisonValue])-  h js1 js2 = let cjs = filter (\j -> any (p j) js2) js1 in-                (cjs, map rev cjs, js1 \\ cjs, js2 \\ map rev cjs)-  p :: Index EgisonValue -> Index EgisonValue -> Bool-  p (Superscript i) (Subscript j) = i == j-  p (Subscript i) (Superscript j) = i == j-  p _ _                           = False-  rev :: Index EgisonValue -> Index EgisonValue-  rev (Superscript i) = Subscript i-  rev (Subscript i)   = Superscript i-  g :: Index EgisonValue -> Index EgisonValue-  g (Superscript i) = SupSubscript i-  g (Subscript i)   = SupSubscript i-  uniq :: [Index EgisonValue] -> [Index EgisonValue]-  uniq []     = []-  uniq (x:xs) = x:uniq (delete x xs)-tProduct f (Scalar x) (Tensor ns xs js) = do-  xs' <- V.mapM (f x) xs-  return $ Tensor ns xs' js-tProduct f (Tensor ns xs js) (Scalar x) = do-  xs' <- V.mapM (`f` x) xs-  return $ Tensor ns xs' js-tProduct f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2--tContract :: HasTensor a => Tensor a -> EgisonM [Tensor a]-tContract t = do-  t' <- tDiag t-  case t' of-    (Tensor (n:ns) xs (SupSubscript i:js)) -> do-      ts <- mapM (`tIntRef'` t') [1..n]-      tss <- mapM toTensor ts >>= mapM tContract-      return $ concat tss-    _ -> return [t']--tContract' :: HasTensor a => Tensor a -> EgisonM (Tensor a)-tContract' t@(Tensor ns xs js) =-  case findPairs p js of-    [] -> return t-    ((m,n):_) -> do-      let ns' = (ns !! m):removePairs (m,n) ns-      let js' = (js !! m):removePairs (m,n) js-      let (hjs, mjs, tjs) = removePairs' (m,n) js-      xs' <- mapM (\i -> tref (hjs ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ mjs-                                    ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ tjs) t)-                  [1..(ns !! m)]-      mapM toTensor xs' >>= tConcat (js !! m) >>= tTranspose (hjs ++ [js !! m] ++ mjs ++ tjs) >>= tContract'- where-  p :: Index EgisonValue -> Index EgisonValue -> Bool-  p (Superscript i) (Superscript j)   = i == j-  p (Subscript i) (Subscript j)       = i == j-  p (DFscript i1 j1) (DFscript i2 j2) = (i1 == i2) && (j1 == j2)-  p _ _                               = False-tContract' val = return val---- utility functions for tensors--nth :: Integer -> [a] -> a-nth i xs = xs !! fromIntegral (i - 1)--cdr :: [a] -> [a]-cdr []     = []-cdr (_:ts) = ts--split :: Integer -> V.Vector a -> [V.Vector a]-split w xs- | V.null xs = []- | otherwise = let (hs, ts) = V.splitAt (fromIntegral w) xs in-                 hs:split w ts--tConcat :: HasTensor a => Index EgisonValue -> [Tensor a] -> EgisonM (Tensor a)-tConcat s (Tensor ns@(0:_) _ js:_) = return $ Tensor (0:ns) V.empty (s:js)-tConcat s ts@(Tensor ns _ js:_) = return $ Tensor (fromIntegral (length ts):ns) (V.concat (map tToVector ts)) (s:js)-tConcat s ts = do-  ts' <- mapM getScalar ts-  return $ Tensor [fromIntegral (length ts)] (V.fromList ts') [s]--tConcat' :: HasTensor a => [Tensor a] -> EgisonM (Tensor a)-tConcat' (Tensor ns@(0:_) _ _:_) = return $ Tensor (0:ns) V.empty []-tConcat' ts@(Tensor ns v _:_) = return $ Tensor (fromIntegral (length ts):ns) (V.concat (map tToVector ts)) []-tConcat' ts = do-  ts' <- mapM getScalar ts-  return $ Tensor [fromIntegral (length ts)] (V.fromList ts') []--getScalar :: Tensor a -> EgisonM a-getScalar (Scalar x) = return x-getScalar _          = throwError $ Default "Inconsitent Tensor order"--findPairs :: (a -> a -> Bool) -> [a] -> [(Int, Int)]-findPairs p xs = reverse $ findPairs' 0 p xs--findPairs' :: Int -> (a -> a -> Bool) -> [a] -> [(Int, Int)]-findPairs' _ _ [] = []-findPairs' m p (x:xs) = case findIndex (p x) xs of-                    Just i  -> (m, m + i + 1):findPairs' (m + 1) p xs-                    Nothing -> findPairs' (m + 1) p xs--removePairs :: (Int, Int) -> [a] -> [a]-removePairs (m, n) xs =-  let (hs, ms, ts) = removePairs' (m, n) xs-   in hs ++ ms ++ ts--removePairs' :: (Int, Int) -> [a] -> ([a],[a],[a])-removePairs' (m, n) xs =         -- (0,1) [i i]-  let (hms, tts) = splitAt n xs  -- [i] [i]-      ts = tail tts              -- []-      (hs, tms) = splitAt m hms  -- [] [i]-      ms = tail tms              -- []-   in (hs, ms, ts)               -- [] [] []- --------  instance Show EgisonValue where   show (Char c) = '\'' : c : "'"@@ -995,9 +345,9 @@   show (ScalarData mExpr) = show mExpr   show (TensorData (Tensor [_] xs js)) = "[| " ++ intercalate ", " (map show (V.toList xs)) ++ " |]" ++ concatMap show js   show (TensorData (Tensor [0, 0] _ js)) = "[| [|  |] |]" ++ concatMap show js-  show (TensorData (Tensor [i, j] xs js)) = "[| " ++ intercalate ", " (f (fromIntegral j) (V.toList xs)) ++ " |]" ++ concatMap show js+  show (TensorData (Tensor [_, j] xs js)) = "[| " ++ intercalate ", " (f (fromIntegral j) (V.toList xs)) ++ " |]" ++ concatMap show js     where-      f j [] = []+      f _ [] = []       f j xs = ["[| " ++ intercalate ", " (map show (take j xs)) ++ " |]"] ++ f j (drop j xs)   show (TensorData (Tensor ns xs js)) = "(tensor [" ++ intercalate ", " (map show ns) ++ "] [" ++ intercalate ", " (map show (V.toList xs)) ++ "] )" ++ concatMap show js   show (Float x) = show x@@ -1018,14 +368,12 @@   show (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)"   show (CFunc (Just name) _ _ _) = show name   show (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ intercalate ", " names ++ "] ...)"-  show (MemoizedFunc (Just name) _ _ _ names _) = show name+  show (MemoizedFunc (Just name) _ _ _ _ _) = show name   show (Proc Nothing _ names _) = "(procedure [" ++ intercalate ", " names ++ "] ...)"   show (Proc (Just name) _ _ _) = name-  show (Macro names _) = "(macro [" ++ intercalate ", " names ++ "] ...)"   show PatternFunc{} = "#<pattern-function>"   show (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"   show (IOFunc _) = "#<io-function>"-  show (QuotedFunc _) = "#<quoted-function>"   show (Port _) = "#<port>"   show Something = "something"   show Undefined = "undefined"@@ -1040,36 +388,6 @@ isAtomic (ScalarData _) = False isAtomic _ = True -instance Show ScalarData where-  show (Div p1 (Plus [Term 1 []])) = show p1-  show (Div p1 p2)                 = show' p1 ++ " / " ++ show' p2-    where-      show' :: PolyExpr -> String-      show' p@(Plus [_]) = show p-      show' p            = "(" ++ show p ++ ")"--instance Show PolyExpr where-  show (Plus [])  = "0"-  show (Plus ts)  = intercalate " + " (map show ts)--instance Show TermExpr where-  show (Term a []) = show a-  show (Term 1 xs) = intercalate " * " (map showPoweredSymbol xs)-  show (Term a xs) = intercalate " * " (show a : map showPoweredSymbol xs)--showPoweredSymbol :: (SymbolExpr, Integer) -> String-showPoweredSymbol (x, 1) = show x-showPoweredSymbol (x, n) = show x ++ "^" ++ show n--instance Show SymbolExpr where-  show (Symbol _ (':':':':':':_) []) = "#"-  show (Symbol _ s []) = s-  show (Symbol _ s js) = s ++ concatMap show js-  show (Apply fn mExprs) = "(" ++ show fn ++ " " ++ unwords (map show mExprs) ++ ")"-  show (Quote mExprs) = "'" ++ show mExprs-  show (FunctionData Nothing argnames args js) = "(functionData [" ++ unwords (map show argnames) ++ "])" ++ concatMap show js-  show (FunctionData (Just name) argnames args js) = show name ++ concatMap show js- instance Eq EgisonValue where  (Char c) == (Char c') = c == c'  (String str) == (String str') = str == str'@@ -1090,7 +408,6 @@  (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _) = name1 == name2  (CFunc Nothing _ x1 expr1) == (CFunc Nothing _ x2 expr2) = (x1 == x2) && (expr1 == expr2)  (CFunc (Just name1) _ _ _) == (CFunc (Just name2) _ _ _) = name1 == name2- (Macro xs1 expr1) == (Macro xs2 expr2) = (xs1 == xs2) && (expr1 == expr2)  _ == _ = False  --@@ -1253,10 +570,6 @@   fromWHNF (Value (Port h)) = return h   fromWHNF whnf             = throwError =<< TypeMismatch "port" whnf <$> getFuncNameStack -class (EgisonWHNF a) => EgisonObject a where-  toObject :: a -> Object-  toObject = WHNF . toWHNF- -- -- Environment --@@ -1264,31 +577,19 @@ data Env = Env [HashMap Var ObjectRef] (Maybe VarWithIndices)  deriving (Show) -data VarWithIndices = VarWithIndices [String] [Index String]- deriving (Eq)- type Binding = (Var, ObjectRef) -instance Show (Index ScalarData) where-  show (Superscript i)  = "~" ++ show i-  show (Subscript i)    = "_" ++ show i-  show (SupSubscript i) = "~_" ++ show i-  show (DFscript _ _)   = ""-  show (Userscript i)   = "|" ++ show i-instance Show VarWithIndices where-  show (VarWithIndices xs is) = intercalate "." xs ++ concatMap show is- instance Show (Index EgisonValue) where   show (Superscript i) = case i of-    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "~[" ++ show i ++ "]"+    ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "~[" ++ show i ++ "]"     _ -> "~" ++ show i   show (Subscript i) = case i of-    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"+    ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"     _ -> "_" ++ show i   show (SupSubscript i) = "~_" ++ show i   show (DFscript i j) = "_d" ++ show i ++ show j   show (Userscript i) = case i of-    ScalarData (Div (Plus [Term 1 [(Symbol id name (a:indices), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"+    ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"     _ -> "|" ++ show i  nullEnv :: Env@@ -1300,24 +601,22 @@ refVar :: Env -> Var -> Maybe ObjectRef refVar (Env env _) var = msum $ map (HashMap.lookup var) env -varToVarWithIndices :: Var -> VarWithIndices-varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is- where-   f :: Index () -> Index String-   f (Superscript ())  = Superscript ""-   f (Subscript ())    = Subscript ""-   f (SupSubscript ()) = SupSubscript ""- -- -- Pattern Match --  type Match = [Binding] -data MatchingState = MState Env [LoopPatContext] [SeqPatContext] [Binding] [MatchingTree]+data MatchingState+  = MState { mStateEnv      :: Env+           , loopPatCtx     :: [LoopPatContext]+           , seqPatCtx      :: [SeqPatContext]+           , mStateBindings :: [Binding]+           , mTrees         :: [MatchingTree]+           }  instance Show MatchingState where-  show (MState _ _ _ bindings mtrees) = "(MState " ++ unwords ["_", "_", "_", show bindings, show mtrees] ++ ")"+  show ms = "(MState " ++ unwords ["_", "_", "_", show (mStateBindings ms), show (mTrees ms)] ++ ")"  data MatchingTree =     MAtom EgisonPattern WHNFData Matcher@@ -1543,7 +842,7 @@ msingleton = flip MCons $ return MNil  mfoldr :: Monad m => (a -> m b -> m b) -> m b -> MList m a -> m b-mfoldr f init MNil         = init+mfoldr _ init MNil         = init mfoldr f init (MCons x xs) = f x (xs >>= mfoldr f init)  mappend :: Monad m => MList m a -> m (MList m a) -> m (MList m a)@@ -1595,17 +894,17 @@ isScalar _              = False  isScalar' :: PrimitiveFunc-isScalar' (Value (ScalarData _)) = return $ Value $ Bool $ True-isScalar' _           = return $ Value $ Bool False+isScalar' (Value (ScalarData _)) = return $ Value $ Bool True+isScalar' _                      = return $ Value $ Bool False  isTensor :: EgisonValue -> Bool isTensor (TensorData _) = True isTensor _              = False  isTensor' :: PrimitiveFunc-isTensor' (Value (TensorData _)) = return $ Value $ Bool $ True-isTensor' (Intermediate (ITensor _)) = return $ Value $ Bool $ True-isTensor' _           = return $ Value $ Bool False+isTensor' (Value (TensorData _))     = return $ Value $ Bool True+isTensor' (Intermediate (ITensor _)) = return $ Value $ Bool True+isTensor' _                          = return $ Value $ Bool False  isTensorWithIndex :: EgisonValue -> Bool isTensorWithIndex (TensorData (Tensor _ _ (_:_))) = True

@@ -48,7 +48,9 @@         Left err -> do           liftIO $ print err           getEgisonExpr opts-        Right topExpr -> return $ Just (input, topExpr)+        Right topExpr -> do+          -- outputStr $ show topExpr+          return $ Just (input, topExpr)  -- |Complete Egison keywords completeEgison :: Monad m => CompletionFunc m@@ -76,11 +78,20 @@ completeEgisonKeyword :: Monad m => String -> m [Completion] completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords +egisonPrimitivesAfterOpenParen :: [String] 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 :: [String] 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", "sort", "intersperse", "intercalate", "split", "split/m"]++egisonKeywordsAfterOpenCons :: [String] egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"]++egisonKeywordsInNeutral :: [String] egisonKeywordsInNeutral = "something" : ["bool", "string", "integer", "nats", "primes"]++egisonKeywords :: [String] egisonKeywords = egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral  completeParen :: Monad m => CompletionFunc m

@@ -47,7 +47,6 @@   toNonS (MemoizedLambdaExpr xs y)  = MemoizedLambdaExpr xs (toNonS y)   toNonS (CambdaExpr _ _)           = error "Not supported"   toNonS (ProcedureExpr xs y)       = ProcedureExpr xs (toNonS y)-  toNonS (MacroExpr xs y)           = MacroExpr xs (toNonS y)   -- PatternFunctionExpr    toNonS (IfExpr x y z)         = IfExpr (toNonS x) (toNonS y) (toNonS z)@@ -80,19 +79,12 @@   toNonS x = x  instance SyntaxElement a => SyntaxElement (Index a) where-  toNonS (Subscript x)          = Subscript (toNonS x)-  toNonS (Superscript x)        = Superscript (toNonS x)-  toNonS (SupSubscript x)       = SupSubscript (toNonS x)-  toNonS (MultiSubscript x y)   = MultiSubscript (toNonS x) (toNonS y)-  toNonS (MultiSuperscript x y) = MultiSuperscript (toNonS x) (toNonS y)-  toNonS (Userscript x)         = Userscript (toNonS x)-  toNonS (DotSubscript x)       = DotSubscript (toNonS x)-  toNonS (DotSupscript x)       = DotSupscript (toNonS x)-  toNonS x = x -- DFScript+  toNonS script = toNonS <$> script  instance SyntaxElement InnerExpr where   toNonS (ElementExpr x) = ElementExpr (toNonS x)-  toNonS (SubCollectionExpr _) = error "Not supported"+--  toNonS (SubCollectionExpr _) = error "Not supported"+  toNonS (SubCollectionExpr _) = ElementExpr UndefinedExpr  instance SyntaxElement BindingExpr where   toNonS (vars, x) = (map toNonS vars, toNonS x)

@@ -74,12 +74,12 @@ ;;; Debug ;;; (define $debug-  (macro [$expr]+  (lambda [%expr]     (io (do {[(print (show expr))]}           (return expr)))))  (define $debug2-  (macro [$msg $expr]+  (lambda [%msg %expr]     (io (do {[(display msg)]              [(print (show expr))]}           (return expr)))))

@@ -4,3 +4,6 @@ (define $dropWhile drop-while) (define $deleteFirst delete-first) (define $deleteFirst/m delete-first/m)++(define $dfNormalize df-normalize)+(define $antisymmetrize df-normalize)

@@ -13,13 +13,13 @@        ; function expression        [<func _ $argnames $args _> (sum (map2 (lambda [$s $r] (* (user-refs f {s}) (∂/∂ r x))) argnames args))]        ; function application-       [(,exp $g) (* (exp g) (∂/∂ g x))]-       [(,log $g) (* (/ 1 g) (∂/∂ g x))]-       [(,sqrt $g) (* (/ 1 (* 2 (sqrt g))) (∂/∂ g x))]-       [(,** $g $h) (* f (∂/∂ (* (log g) h) x))]-       [(,cos $g) (* (* -1 (sin g)) (∂/∂ g x))]-       [(,sin $g) (* (cos g) (∂/∂ g x))]-       [(,arccos $g) (* (/ 1 (sqrt (- 1 (** g 2)))) (∂/∂ g x))]+       [(,`exp $g) (* (exp g) (∂/∂ g x))]+       [(,`log $g) (* (/ 1 g) (∂/∂ g x))]+       [(,`sqrt $g) (* (/ 1 (* 2 (sqrt g))) (∂/∂ g x))]+       [(,`** $g $h) (* f (∂/∂ (* (log g) h) x))]+       [(,`cos $g) (* (* -1 (sin g)) (∂/∂ g x))]+       [(,`sin $g) (* (cos g) (∂/∂ g x))]+       [(,`arccos $g) (* (/ 1 (sqrt (- 1 (** g 2)))) (∂/∂ g x))]        [<apply $g $args>         (sum (map 2#(* (capply `(user-refs g {%1}) args) (∂/∂ %2 x))                   (zip nats args)))]

@@ -4,12 +4,12 @@ ;;;;; ;;;;; -(define $to-math-expr (macro [$arg] (math-normalize1 (apply to-math-expr' arg))))+(define $to-math-expr (lambda [$arg] (math-normalize1 (apply to-math-expr' arg)))) -(define $+' (cambda $xs (foldl b.+' (car xs) (cdr xs))))-(define $-' (cambda $xs (foldl b.-' (car xs) (cdr xs))))-(define $*' (cambda $xs (foldl b.*' (car xs) (cdr xs))))-(define $/' b./')+(define $+' (cambda $xs (foldl b.+ (car xs) (cdr xs))))+(define $-' (cambda $xs (foldl b.- (car xs) (cdr xs))))+(define $*' (cambda $xs (foldl b.* (car xs) (cdr xs))))+(define $/' b./)  (define $f.+' (cambda $xs (foldl f.+ (car xs) (cdr xs)))) (define $f.-' (cambda $xs (foldl f.- (car xs) (cdr xs))))

@@ -16,15 +16,15 @@    [id 1##t]    [rewrite-rule-for-i 1#(contain-symbol? i %1)]    [rewrite-rule-for-w-term 1#(contain-symbol? w %1)]-   [rewrite-rule-for-rtu-term 1#(contain-function? rtu %1)]-   [rewrite-rule-for-** 1#(contain-function? ** %1)]-   [rewrite-rule-for-exp 1#(contain-function? exp %1)]+   [rewrite-rule-for-rtu-term 1#(contain-function? `rtu %1)]+   [rewrite-rule-for-** 1#(contain-function? `** %1)]+   [rewrite-rule-for-exp 1#(contain-function? `exp %1)]    [rewrite-rule-for-w-poly 1#(contain-symbol? w %1)]-   [rewrite-rule-for-rtu-poly 1#(contain-function? rtu %1)]-   [rewrite-rule-for-sqrt 1#(contain-function? sqrt %1)]-   [rewrite-rule-for-rt 1#(contain-function? rt %1)]-;   [rewrite-rule-for-cos-and-sin 1#(or (contain-function-with-order? cos 2 %1) (contain-function-with-order? sin 2 %1))]-   [rewrite-rule-for-cos-to-sin 1#(contain-function-with-order? cos 2 %1)]+   [rewrite-rule-for-rtu-poly 1#(contain-function? `rtu %1)]+   [rewrite-rule-for-sqrt 1#(contain-function? `sqrt %1)]+   [rewrite-rule-for-rt 1#(contain-function? `rt %1)]+;   [rewrite-rule-for-cos-and-sin 1#(or (contain-function-with-order? `cos 2 %1) (contain-function-with-order? `sin 2 %1))]+   [rewrite-rule-for-cos-to-sin 1#(contain-function-with-order? `cos 2 %1)]    [rewrite-rule-for-d/d 1##t]    }) @@ -91,7 +91,7 @@ (define $rewrite-rule-for-rtu-term'   (lambda [$term]     (match term math-expr-      {[(* $a (,rtu $n)^(& ?(gte? $ n) $k) $r)+      {[(* $a (,`rtu $n)^(& ?(gte? $ n) $k) $r)         (*' a (**' (rtu n) (remainder k n)) r)]        [_ term]}))) @@ -115,9 +115,9 @@ (define $rewrite-rule-for-sqrt-term   (lambda [$term]     (match term math-expr-      {[(* $a (,sqrt $x) (,sqrt ,x) $r)+      {[(* $a (,`sqrt $x) (,`sqrt ,x) $r)         (rewrite-rule-for-sqrt (*' a x r))]-       [(* $a (,sqrt (& ?term? $x)) (,sqrt (& ?term? $y)) $r)+       [(* $a (,`sqrt (& ?term? $x)) (,`sqrt (& ?term? $y)) $r)         (let* {[$d (gcd x y)]                [[$a1 $x1] (from-monomial (/ x d))]                [[$a2 $y1] (from-monomial (/ y d))]}@@ -136,7 +136,7 @@ (define $rewrite-rule-for-rt-term   (lambda [$term]     (match term math-expr-      {[(* $a (,rt $n $x)^(& ?(gte? $ n) $k) $r)+      {[(* $a (,`rt $n $x)^(& ?(gte? $ n) $k) $r)         (*' a (**' x (quotient k n)) (**' (rt n x) (remainder k n)) r)]        [_ term]}))) @@ -149,9 +149,9 @@ (define $rewrite-rule-for-exp-term   (lambda [$term]     (match term math-expr-      {[(* $a (,exp $x)^(& ?(gte? $ 2) $n) $r)+      {[(* $a (,`exp $x)^(& ?(gte? $ 2) $n) $r)         (rewrite-rule-for-exp (*' a (exp (* x n)) r))]-       [(* $a (,exp $x) (,exp $y) $r)+       [(* $a (,`exp $x) (,`exp $y) $r)         (rewrite-rule-for-exp (*' a (exp (+ x y)) r))]        [_ term]}))) @@ -164,11 +164,11 @@ (define $rewrite-rule-for-**-term   (lambda [$term]     (match term math-expr-      {[(* $a (,** ,1 _)^_ $r)+      {[(* $a (,`** ,1 _)^_ $r)         (rewrite-rule-for-** (*' a r))]-       [(* $a (,** $x $y)^(& ?(gte? $ 2) $n) $r)+       [(* $a (,`** $x $y)^(& ?(gte? $ 2) $n) $r)         (rewrite-rule-for-** (*' a (** x (* y n)) r))]-       [(* $a (,** $x $y) (,** ,x $z) $r)+       [(* $a (,`** $x $y) (,`** ,x $z) $r)         (rewrite-rule-for-** (*' a (** x (+ y z)) r))]        [_ term]}))) @@ -182,45 +182,45 @@ (define $rewrite-rule-for-cos-and-sin-expr   (lambda [$expr]     (match [expr expr] [math-expr math-expr]-      {[[<div (+ (* $a (,cos $x) $mr)+      {[[<div (+ (* $a (,`cos $x) $mr)                  $pr1)               $pr2>-         (| <div (+ (* _ (| (,cos ,(/ x 2)) (,sin ,(/ x 2))) _) _) _>-            <div _ (+ (* _ (| (,cos ,(/ x 2)) (,sin ,(/ x 2))) _) _)>)]+         (| <div (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _) _>+            <div _ (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _)>)]         (rewrite-rule-for-cos-and-sin-expr (/' (+' (*' a (-' (cos (/ x 2))^2 (sin (/ x 2))^2) mr) pr1) pr2))]-       [[<div (+ (* $a (,sin $x) $mr)+       [[<div (+ (* $a (,`sin $x) $mr)                  $pr1)               $pr2>-         (| <div (+ (* _ (| (,cos ,(/ x 2)) (,sin ,(/ x 2))) _) _) _>-            <div _ (+ (* _ (| (,cos ,(/ x 2)) (,sin ,(/ x 2))) _) _)>)]+         (| <div (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _) _>+            <div _ (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _)>)]         (rewrite-rule-for-cos-and-sin-expr (/' (+' (*' (*' a 2) (*' (cos (/ x 2)) (sin (/ x 2))) mr) pr1) pr2))]        [[<div $pr2-              (+ (* $a (,cos $x) $mr)+              (+ (* $a (,`cos $x) $mr)                  $pr1)>-         (| <div (+ (* _ (| (,cos ,(/ x 2)) (,sin ,(/ x 2))) _) _) _>-            <div _ (+ (* _ (| (,cos ,(/ x 2)) (,sin ,(/ x 2))) _) _)>)]+         (| <div (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _) _>+            <div _ (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _)>)]         (rewrite-rule-for-cos-and-sin-expr (/' pr2 (+' (*' a (-' (cos (/ x 2))^2 (sin (/ x 2))^2) mr) pr1)))]        [[<div $pr2-              (+ (* $a (,sin $x) $mr)+              (+ (* $a (,`sin $x) $mr)                  $pr1)>-         (| <div (+ (* _ (| (,cos ,(/ x 2)) (,sin ,(/ x 2))) _) _) _>-            <div _ (+ (* _ (| (,cos ,(/ x 2)) (,sin ,(/ x 2))) _) _)>)]+         (| <div (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _) _>+            <div _ (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _)>)]         (rewrite-rule-for-cos-and-sin-expr (/' pr2 (+' (*' (*' a 2) (*' (cos (/ x 2)) (sin (/ x 2))) mr) pr1)))]        [_ expr]})))  (define $rewrite-rule-for-cos-and-sin-poly   (lambda [$poly]     (match poly math-expr-      {[(+ (* $a (,cos $x)^,2 $mr)-           (* ,a (,sin ,x)^,2 ,mr)+      {[(+ (* $a (,`cos $x)^,2 $mr)+           (* ,a (,`sin ,x)^,2 ,mr)            $pr)         (rewrite-rule-for-cos-and-sin-poly (+' pr (*' a mr)))]        [(+ (* $a $mr)-           (* ,(* -1 a) (,sin $x)^,2 ,mr)+           (* ,(* -1 a) (,`sin $x)^,2 ,mr)            $pr)         (rewrite-rule-for-cos-and-sin-poly (+' pr (*' a (cos x)^2 mr)))]        [(+ (* $a $mr)-           (* ,(* -1 a) (,cos $x)^,2 ,mr)+           (* ,(* -1 a) (,`cos $x)^,2 ,mr)            $pr)         (rewrite-rule-for-cos-and-sin-poly (+' pr (*' a (sin x)^2 mr)))]        [_ poly]})))@@ -230,7 +230,7 @@ (define $rewrite-rule-for-cos-to-sin-term'   (lambda [$term]     (match term math-expr-      {[(* $a (,cos $x)^,2 $mr)+      {[(* $a (,`cos $x)^,2 $mr)         (*' a (-' 1 (sin x)^2) (rewrite-rule-for-cos-to-sin-term' mr))]        [_ term]}))) 

@@ -50,7 +50,7 @@ assertEqual "truncate" (truncate (-2.2)) (-2) assertEqual "truncate" (truncate (-2.7)) (-2) --- assertEqual "sqrt" (sqrt 4) 2+assertEqual "sqrt" (sqrt 4) 2 assertEqual "sqrt" (sqrt 4.0) 2.0 -- assertEqual "sqrt" (sqrt (-1)) i 

@@ -31,8 +31,6 @@  assertEqual "tuple literal" (1, 2, 3) (1, 2, 3) -assertEqual "singleton tuple literal" (1) 1- assertEqual "collection literal" [1, 2, 3, 4, 5, 6] [1, 2, 3, 4, 5, 6]  assertEqual "collection between" [1..5] [1, 2, 3, 4, 5]@@ -62,14 +60,14 @@     in y)   2 -assertEqual "let binding without indent"+assertEqual "let binding without newline"   (let { x := 1; y := x + 1 } in y)   2  io do print "io and do expression"       return 0 -io do { print "io and do expression without indent"; return 0 }+io do { print "io and do expression without newline"; return 0 }  assertEqual "where"   (f 0 + y + 1@@ -85,6 +83,14 @@       z := 4)   10 +assertEqual "multiple where in one expression"+  (matchAll [1, 2, 3] as multiset integer with+   | #1 :: $xs -> f xs+     where f xs := length xs+   | #2 :: #3 :: $xs -> g xs+     where g xs := length xs)+  [2, 1]+ assertEqual "mutual recursion"   (let even? n := if n = 0 then True else odd? (n - 1)        odd?  n := if n = 0 then False else even? (n - 1)@@ -102,21 +108,27 @@ assertEqual "append op" ([1] ++ [2]) [1, 2] assertEqual "append op" ((++) [1] [2]) [1, 2] -assertEqual "point free expr" ((+) 10 1) 11-assertEqual "point free expr" ((+ 1) 10) 11-assertEqual "point free expr" (foldl (*) 1 [1..5]) 120-assertEqual "point free expr" ((10 -) 1) 9-assertEqual "point free expr" ((10 - ) 1) 9-assertEqual "not point free expr" (- 2) (1 - 3)+assertEqual "section" ((+) 10 1) 11+assertEqual "section" ((+ 1) 10) 11+assertEqual "section" (foldl (*) 1 [1..5]) 120+assertEqual "section" ((-) 10 1) 9+assertEqual "section" ((10 -) 1) 9+assertEqual "section" ((10 - ) 1) 9+assertEqual "section" ((-1 +) 2) 1+assertEqual "safe section - left assoc"  ((1 + 2 +) 3) 6+assertEqual "safe section - right assoc" ((++ [1] ++ [2]) [3]) [3, 1, 2]+assertEqual "not section" (- 2) (1 - 3) --- findFactor := memoizedLambda---                n -> match takeWhile (<= floor (sqrt (itof n))) primes as list integer with---                     | _ ++ (?(\m -> divisor? n m) & $x) :: _ -> x---                     | _ -> n--- assertEqual "memoized lambda"---   (map findFactor [1..10])---   [1, 2, 3, 2, 5, 2, 7, 2, 3, 2]+findFactor :=+  memoizedLambda n ->+    match takeWhile (<= floor (sqrt (itof n))) primes as list integer with+    | _ ++ (?(\m -> divisor? n m) & $x) :: _ -> x+    | _ -> n +assertEqual "memoized lambda"+  (map findFactor [1..10])+  [1, 2, 3, 2, 5, 2, 7, 2, 3, 2]+ twinPrimes :=   matchAll primes as list integer with   | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2)@@ -151,6 +163,21 @@   (gcd 143 22)   11 +A x := 1++assertEqual "definition of upper-case identifier"+  (A 2)+  1++{-+  This is a comment+ -}++{-+  {- We can nest comments! -}+  {- {- nested -} comment -}+ -}+ -- -- Pattern-Matching --@@ -406,10 +433,20 @@   ([| 1, 2, 3 |] !+ [| 1, 2, 3 |])   [| [| 2, 3, 4 |], [| 3, 4, 5 |], [| 4, 5, 6 |] |] +-- assertEqual "tensor wedge expr of binary operator - section style"+--   ((!+) [| 1, 2, 3 |] [| 1, 2, 3 |])+--   [| [| 2, 3, 4 |], [| 3, 4, 5 |], [| 4, 5, 6 |] |]+ assertEqual "tensor multiplication"   ([| 1, 2, 3 |]_i * [| 1, 2, 3 |]_i)   [| 1, 4, 9 |]_i +assertEqual "multi subscript"+  (let i := {| (1, 1), (2, 2), (3, 3) |}+       x := generateTensor (\x y z -> x + y + z) [5, 5, 5]+    in x_(i_1)..._(i_3))+  6+ -- -- Hash --@@ -426,16 +463,20 @@   {| (1, 11), (2, 12), (3, 13), (4, 14), (5, 15), |}_3   13 +-- assertEqual "string hash access"+--   {| ("1", 11), ("2", 12), ("3", 13), ("4", 14), ("5", 15) |}_"3"+--   13+ -- -- Partial Application -------- assertEqual "partial application '#'"---   2#(10 * %1 + %2)(1, 2)---   12---++assertEqual "partial application '#'"+  (2#(10 * %1 + %2) 1 2)+  12+ -- assertEqual "recursive partial application '#'"---   take(10, 1#[%1, @(%0(%1 * 2))](2))+--   (take 10 (1#(%1 :: (%0 (%1 * %2))) 2)) --   [2, 4, 8, 16, 32, 64, 128, 256, 512, 1024]  f *x *y := x + y@@ -451,7 +492,7 @@   [| [| 11, 21, 31, |], [| 12, 22, 32, |], [| 13, 23, 33, |], |]_i~j  ----- matcherExpr, macroExpr+-- matcherExpr --  list a := matcher@@ -501,13 +542,12 @@    | $x :: _ -> x)   [1, 2, 3] -nishiwakiIf :=-  macro b e1 e2 ->-    car (matchAll b as (matcher-                        | $ as something with-                            | True  -> [e1]-                            | False -> [e2]) with-         | $x -> x)+nishiwakiIf b e1 e2 :=+  car (matchAll b as (matcher+                      | $ as something with+                          | True  -> [e1]+                          | False -> [e2]) with+       | $x -> x)  assertEqual "case 1" (nishiwakiIf True     1 2) 1 assertEqual "case 2" (nishiwakiIf False    1 2) 2

@@ -22,10 +22,10 @@     (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))        (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l))))) -R~#_#_1_1;[| [| 0 0 |] [| 0 0 |] |]~#_#-R~#_#_1_2;[| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_#-R~#_#_2_1;[| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_#-R~#_#_2_2;[| [| 0 0 |] [| 0 0 |] |]~#_#+(assert-equal "Riemann curvature" R~#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]~#_#)+(assert-equal "Riemann curvature" R~#_#_1_2 [| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_#)+(assert-equal "Riemann curvature" R~#_#_2_1 [| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_#)+(assert-equal "Riemann curvature" R~#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]~#_#)  ;;; Connection form @@ -46,9 +46,9 @@     (df-normalize (+ (d ω~i_j)                      (wedge ω~i_k ω~k_j))))) -Ω~#_#_1_1;[| [| 0 0 |] [| 0 0 |] |]~#_#-Ω~#_#_1_2;[| [| 0 (/ (sin θ)^2 2) |] [| (/ -1 2) 0 |] |]~#_#-Ω~#_#_2_1;[| [| 0 (/ (* -1 (sin θ)^2) 2) |] [| (/ 1 2) 0 |] |]~#_#-Ω~#_#_2_2;[| [| 0 0 |] [| 0 0 |] |]~#_#+(assert-equal "Curvature form" Ω~#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]~#_#)+(assert-equal "Curvature form" Ω~#_#_1_2 [| [| 0 (/ (sin θ)^2 2) |] [| (/ -1 2) 0 |] |]~#_#)+(assert-equal "Curvature form" Ω~#_#_2_1 [| [| 0 (/ (* -1 (sin θ)^2) 2) |] [| (/ 1 2) 0 |] |]~#_#)+(assert-equal "Curvature form" Ω~#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]~#_#)  

@@ -14,10 +14,11 @@ ;;  (define $e_i_j (∂/∂ X_j x~i))-e_i_j-;[|[|(* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |]-;  [|(* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |]-;  |]_i_j+(assert-equal "Local basis"+  e_#_#+  [|[|(* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |]+    [|(* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |]+    |]_#_#)  ;; ;; Metric tensor@@ -26,8 +27,8 @@ (define $g__ (generate-tensor 2#(V.* e_%1_# e_%2_#) {2 2})) (define $g~~ (M.inverse g_#_#)) -g_#_#;[| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |]_#_#-g~#~#;[| [| (/ 1 r^2) 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) |] |]~#~#+(assert-equal "Metric tensor 1" g_#_# [| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |]_#_#)+(assert-equal "Metroc tensor 2" g~#~# [| [| (/ 1 r^2) 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) |] |]~#~#)  ;; ;; Christoffel symbols of the first kind@@ -39,9 +40,9 @@         (∂/∂ g_j_k x~l)         (* -1 (∂/∂ g_k_l x~j))))) -Γ_#_#_#;(tensor {2 2 2} {0 0 0 (* -1 r^2 (sin θ) (cos θ)) 0 (* r^2 (sin θ) (cos θ)) (* r^2 (sin θ) (cos θ)) 0} )_#_#_#-Γ_1_#_#;[| [| 0 0 |] [| 0 (* -1 r^2 (sin θ) (cos θ)) |] |]_#_#-Γ_2_#_#;[| [| 0 (* r^2 (sin θ) (cos θ)) |] [| (* r^2 (sin θ) (cos θ)) 0 |] |]_#_#+(assert-equal "Christoffel symbols of the first kind" Γ_#_#_# (tensor {2 2 2} {0 0 0 (* -1 r^2 (sin θ) (cos θ)) 0 (* r^2 (sin θ) (cos θ)) (* r^2 (sin θ) (cos θ)) 0} )_#_#_#)+(assert-equal "Christoffel symbols of the first kind" Γ_1_#_# [| [| 0 0 |] [| 0 (* -1 r^2 (sin θ) (cos θ)) |] |]_#_#)+(assert-equal "Christoffel symbols of the first kind" Γ_2_#_# [| [| 0 (* r^2 (sin θ) (cos θ)) |] [| (* r^2 (sin θ) (cos θ)) 0 |] |]_#_#)  ;; ;; Christoffel symbols of the second kind@@ -49,9 +50,9 @@  (define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#))) -Γ~#_#_#;(tensor {2 2 2} {0 0 0 (* -1 (sin θ) (cos θ)) 0 (/ (cos θ) (sin θ)) (/ (cos θ) (sin θ)) 0} )~#_#_#-Γ~1_#_#;[| [| 0 0 |] [| 0 (* -1 (sin θ) (cos θ)) |] |]_#_#-Γ~2_#_#;[| [| 0 (/ (cos θ) (sin θ)) |] [| (/ (cos θ) (sin θ)) 0 |] |]_#_#+(assert-equal "Christoffel symbols of the second kind" Γ~#_#_# (tensor {2 2 2} {0 0 0 (* -1 (sin θ) (cos θ)) 0 (/ (cos θ) (sin θ)) (/ (cos θ) (sin θ)) 0} )~#_#_#)+(assert-equal "Christoffel symbols of the second kind" Γ~1_#_# [| [| 0 0 |] [| 0 (* -1 (sin θ) (cos θ)) |] |]_#_#)+(assert-equal "Christoffel symbols of the second kind" Γ~2_#_# [| [| 0 (/ (cos θ) (sin θ)) |] [| (/ (cos θ) (sin θ)) 0 |] |]_#_#)  ;; ;; Covariant derivative of metric tensor@@ -62,7 +63,7 @@        (. Γ~n_m_i g_n_j)        (. Γ~n_m_j g_i_n)))) -∇g_#_#_#;=>(tensor {2 2 2} {0 0 0 0 0 0 0 0} )+(assert-equal "Covariant derivative of metric tensor" ∇g_#_#_# (tensor {2 2 2} {0 0 0 0 0 0 0 0} ))  ;; ;; Riemann curvature tensor@@ -73,19 +74,19 @@     (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))        (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l))))) -R~#_#_#_#;(tensor {2 2 2 2} {0 0 0 0 0 (sin θ)^2 (* -1 (sin θ)^2) 0 0 -1 1 0 0 0 0 0} )~#_#_#_#-R~#_#_1_1;[| [| 0 0 |] [| 0 0 |] |]~#_#-R~#_#_1_2;[| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_#-R~#_#_2_1;[| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_#-R~#_#_2_2;[| [| 0 0 |] [| 0 0 |] |]~#_#+(assert-equal "Riemann curvature" R~#_#_#_# (tensor {2 2 2 2} {0 0 0 0 0 (sin θ)^2 (* -1 (sin θ)^2) 0 0 -1 1 0 0 0 0 0} )~#_#_#_#)+(assert-equal "Riemann curvature" R~#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]~#_#)+(assert-equal "Riemann curvature" R~#_#_1_2 [| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_#)+(assert-equal "Riemann curvature" R~#_#_2_1 [| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_#)+(assert-equal "Riemann curvature" R~#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]~#_#)  (define $R____ (with-symbols {i} (. g_i_# R~i_#_#_#))) -R_#_#_#_#;(tensor {2 2 2 2} {0 0 0 0 0 (* r^2 (sin θ)^2) (* -1 r^2 (sin θ)^2) 0 0 (* -1 r^2 (sin θ)^2) (* r^2 (sin θ)^2) 0 0 0 0 0} )_#_#_#_#-R_#_#_1_1;[| [| 0 0 |] [| 0 0 |] |]_#_#-R_#_#_1_2;[| [| 0 (* r^2 (sin θ)^2) |] [| (* -1 r^2 (sin θ)^2) 0 |] |]_#_#-R_#_#_2_1;[| [| 0 (* -1 r^2 (sin θ)^2) |] [| (* r^2 (sin θ)^2) 0 |] |]_#_#-R_#_#_2_2;[| [| 0 0 |] [| 0 0 |] |]_#_#+(assert-equal "Riemann curvature" R_#_#_#_# (tensor {2 2 2 2} {0 0 0 0 0 (* r^2 (sin θ)^2) (* -1 r^2 (sin θ)^2) 0 0 (* -1 r^2 (sin θ)^2) (* r^2 (sin θ)^2) 0 0 0 0 0} )_#_#_#_#)+(assert-equal "Riemann curvature" R_#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]_#_#)+(assert-equal "Riemann curvature" R_#_#_1_2 [| [| 0 (* r^2 (sin θ)^2) |] [| (* -1 r^2 (sin θ)^2) 0 |] |]_#_#)+(assert-equal "Riemann curvature" R_#_#_2_1 [| [| 0 (* -1 r^2 (sin θ)^2) |] [| (* r^2 (sin θ)^2) 0 |] |]_#_#)+(assert-equal "Riemann curvature" R_#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]_#_#)  ;; ;; Ricci curvature@@ -93,7 +94,7 @@  (define $Ric__ (with-symbols {i} (contract + R~i_#_i_#))) -Ric_#_#;[| [| 1 0 |] [| 0 (sin θ)^2 |] |]_#_#+(assert-equal "Ricci curvature" Ric_#_# [| [| 1 0 |] [| 0 (sin θ)^2 |] |]_#_#)  ;; ;; Scalar curvature@@ -101,7 +102,7 @@  (define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k))) -scalar-curvature;(/ 2 r^2)+(assert-equal "Scalar curvature" scalar-curvature (/ 2 r^2))  ;; ;; Covariant derivative of Riemann curvature tensor@@ -115,5 +116,6 @@        (. Γ~n_m_k R_i_j_n_l)        (. Γ~n_m_l R_i_j_k_n)))) -∇R_#_#_#_#_#-;(tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#_#+(assert-equal "Covariant derivative of Riemann curvature tensor"+  ∇R_#_#_#_#_#+  (tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#_#)

@@ -14,10 +14,11 @@ ;;  (define $e ((flip ∂/∂) x~# X_#))-e-;[|[| (* -1 a (sin θ) (cos φ)) (* -1 a (sin θ) (sin φ)) (* a (cos θ)) |]-;  [| (* -1 '(+ (* a (cos θ)) b) (sin φ)) (* '(+ (* a (cos θ)) b) (cos φ)) 0 |]-;  |]~#~#+(assert-equal "Local basis"+  e_#_#+  [|[| (* -1 a (sin θ) (cos φ)) (* -1 a (sin θ) (sin φ)) (* a (cos θ)) |]+    [| (* -1 '(+ (* a (cos θ)) b) (sin φ)) (* '(+ (* a (cos θ)) b) (cos φ)) 0 |]+    |]_#_#)  ;; ;; Metric tensor@@ -26,8 +27,8 @@ (define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {2 2})) (define $g~~ (M.inverse g_#_#)) -g_#_#;[| [| a^2 0 |] [| 0 '(+ (* a (cos θ)) b)^2 |] |]_#_#-g~#~#;[| [| (/ 1 a^2) 0 |] [| 0 (/ 1 '(+ (* a (cos θ)) b)^2) |] |]~#~#+(assert-equal "Metric tensor 1" g_#_# [| [| a^2 0 |] [| 0 '(+ (* a (cos θ)) b)^2 |] |]_#_#)+(assert-equal "Metroc tensor 2" g~#~# [| [| (/ 1 a^2) 0 |] [| 0 (/ 1 '(+ (* a (cos θ)) b)^2) |] |]~#~#)  ;; ;; Christoffel symbols of the first kind@@ -39,9 +40,9 @@         (∂/∂ g_i_k x~j)         (* -1 (∂/∂ g_j_k x~i))))) -Γ_#_#_#;(tensor {2 2 2} {0 0 0 (* '(+ (* a (cos θ)) b) a (sin θ)) 0 (* -1 '(+ (* a (cos θ)) b) a (sin θ)) (* -1 '(+ (* a (cos θ)) b) a (sin θ)) 0} )_#_#_#-Γ_1_#_#;[| [| 0 0 |] [| 0 (* '(+ (* a (cos θ)) b) a (sin θ)) |] |]_#_#-Γ_2_#_#;[| [| 0 (* -1 '(+ (* a (cos θ)) b) a (sin θ)) |] [| (* -1 '(+ (* a (cos θ)) b) a (sin θ)) 0 |] |]_#_#+(assert-equal "Christoffel symbols of the first kind" Γ_#_#_# (tensor {2 2 2} {0 0 0 (* '(+ (* a (cos θ)) b) a (sin θ)) 0 (* -1 '(+ (* a (cos θ)) b) a (sin θ)) (* -1 '(+ (* a (cos θ)) b) a (sin θ)) 0} )_#_#_#)+(assert-equal "Christoffel symbols of the first kind" Γ_1_#_# [| [| 0 0 |] [| 0 (* '(+ (* a (cos θ)) b) a (sin θ)) |] |]_#_#)+(assert-equal "Christoffel symbols of the first kind" Γ_2_#_# [| [| 0 (* -1 '(+ (* a (cos θ)) b) a (sin θ)) |] [| (* -1 '(+ (* a (cos θ)) b) a (sin θ)) 0 |] |]_#_#)  ;; ;; Christoffel symbols of the second kind@@ -49,9 +50,9 @@  (define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#))) -Γ~#_#_#;(tensor {2 2 2} {0 0 0 (/ (* '(+ (* a (cos θ)) b) (sin θ)) a) 0 (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) 0} )~#_#_#-Γ~1_#_#;[| [| 0 0 |] [| 0 (/ (* '(+ (* a (cos θ)) b) (sin θ)) a) |] |]_#_#-Γ~2_#_#;[| [| 0 (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) |] [| (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) 0 |] |]_#_#+(assert-equal "Christoffel symbols of the second kind" Γ~#_#_# (tensor {2 2 2} {0 0 0 (/ (* '(+ (* a (cos θ)) b) (sin θ)) a) 0 (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) 0} )~#_#_#)+(assert-equal "Christoffel symbols of the second kind" Γ~1_#_# [| [| 0 0 |] [| 0 (/ (* '(+ (* a (cos θ)) b) (sin θ)) a) |] |]_#_#)+(assert-equal "Christoffel symbols of the second kind" Γ~2_#_# [| [| 0 (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) |] [| (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) 0 |] |]_#_#)  ;; ;; Covariant derivative of metric tensor@@ -62,7 +63,7 @@        (. Γ~n_m_i g_n_j)        (. Γ~n_m_j g_i_n)))) -∇g_#_#_#;=>(tensor {2 2 2} {0 0 0 0 0 0 0 0} )+(assert-equal "Covariant derivative of metric tensor" ∇g_#_#_# (tensor {2 2 2} {0 0 0 0 0 0 0 0} ))  ;; ;; Riemann curvature tensor@@ -73,19 +74,19 @@     (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))        (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l))))) -R~#_#_#_#;(tensor {2 2 2 2} {0 0 0 0 0 (/ (* '(+ (* a (cos θ)) b) (cos θ)) a) (/ (* -1 '(+ (* a (cos θ)) b) (cos θ)) a) 0 0 (/ (* -1 a (cos θ)) '(+ (* a (cos θ)) b)) (/ (* a (cos θ)) '(+ (* a (cos θ)) b)) 0 0 0 0 0} )~#_#_#_#-R~#_#_1_1;[| [| 0 0 |] [| 0 0 |] |]~#_#-R~#_#_1_2;[| [| 0 (/ (* '(+ (* a (cos θ)) b) (cos θ)) a) |] [| (/ (* -1 a (cos θ)) '(+ (* a (cos θ)) b)) 0 |] |]~#_#-R~#_#_2_1;[| [| 0 (/ (* -1 '(+ (* a (cos θ)) b) (cos θ)) a) |] [| (/ (* a (cos θ)) '(+ (* a (cos θ)) b)) 0 |] |]~#_#-R~#_#_2_2;[| [| 0 0 |] [| 0 0 |] |]~#_#+(assert-equal "Riemann curvature" R~#_#_#_# (tensor {2 2 2 2} {0 0 0 0 0 (/ (* '(+ (* a (cos θ)) b) (cos θ)) a) (/ (* -1 '(+ (* a (cos θ)) b) (cos θ)) a) 0 0 (/ (* -1 a (cos θ)) '(+ (* a (cos θ)) b)) (/ (* a (cos θ)) '(+ (* a (cos θ)) b)) 0 0 0 0 0} )~#_#_#_#)+(assert-equal "Riemann curvature" R~#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]~#_#)+(assert-equal "Riemann curvature" R~#_#_1_2 [| [| 0 (/ (* '(+ (* a (cos θ)) b) (cos θ)) a) |] [| (/ (* -1 a (cos θ)) '(+ (* a (cos θ)) b)) 0 |] |]~#_#)+(assert-equal "Riemann curvature" R~#_#_2_1 [| [| 0 (/ (* -1 '(+ (* a (cos θ)) b) (cos θ)) a) |] [| (/ (* a (cos θ)) '(+ (* a (cos θ)) b)) 0 |] |]~#_#)+(assert-equal "Riemann curvature" R~#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]~#_#)  (define $R____ (with-symbols {i} (. g_i_# R~i_#_#_#))) -R_#_#_#_#;(tensor {2 2 2 2} {0 0 0 0 0 (* a '(+ (* a (cos θ)) b) (cos θ)) (* -1 a '(+ (* a (cos θ)) b) (cos θ)) 0 0 (* -1 '(+ (* a (cos θ)) b) a (cos θ)) (* '(+ (* a (cos θ)) b) a (cos θ)) 0 0 0 0 0} )_#_#_#_#-R_#_#_1_1;[| [| 0 0 |] [| 0 0 |] |]_#_#-R_#_#_1_2;[| [| 0 (* a '(+ (* a (cos θ)) b) (cos θ)) |] [| (* -1 '(+ (* a (cos θ)) b) a (cos θ)) 0 |] |]_#_#-R_#_#_2_1;[| [| 0 (* -1 a '(+ (* a (cos θ)) b) (cos θ)) |] [| (* '(+ (* a (cos θ)) b) a (cos θ)) 0 |] |]_#_#-R_#_#_2_2;[| [| 0 0 |] [| 0 0 |] |]_#_#+(assert-equal "Riemann curvature" R_#_#_#_# (tensor {2 2 2 2} {0 0 0 0 0 (* a '(+ (* a (cos θ)) b) (cos θ)) (* -1 a '(+ (* a (cos θ)) b) (cos θ)) 0 0 (* -1 '(+ (* a (cos θ)) b) a (cos θ)) (* '(+ (* a (cos θ)) b) a (cos θ)) 0 0 0 0 0} )_#_#_#_#)+(assert-equal "Riemann curvature" R_#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]_#_#)+(assert-equal "Riemann curvature" R_#_#_1_2 [| [| 0 (* a '(+ (* a (cos θ)) b) (cos θ)) |] [| (* -1 '(+ (* a (cos θ)) b) a (cos θ)) 0 |] |]_#_#)+(assert-equal "Riemann curvature" R_#_#_2_1 [| [| 0 (* -1 a '(+ (* a (cos θ)) b) (cos θ)) |] [| (* '(+ (* a (cos θ)) b) a (cos θ)) 0 |] |]_#_#)+(assert-equal "Riemann curvature" R_#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]_#_#)  ;; ;; Ricci curvature@@ -93,7 +94,7 @@  (define $Ric__ (with-symbols {i} (contract + R~i_#_i_#))) -Ric_#_#;[| [| (/ (* a (cos θ)) '(+ (* a (cos θ)) b)) 0 |] [| 0 (/ (* '(+ (* a (cos θ)) b) (cos θ)) a) |] |]_#_#+(assert-equal "Ricci curvature" Ric_#_# [| [| (/ (* a (cos θ)) '(+ (* a (cos θ)) b)) 0 |] [| 0 (/ (* '(+ (* a (cos θ)) b) (cos θ)) a) |] |]_#_#)  ;; ;; Scalar curvature@@ -101,7 +102,7 @@  (define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k))) -scalar-curvature;(/ (* 2 (cos θ)) (* a '(+ (* a (cos θ)) b)))+(assert-equal "Scalar curvature" scalar-curvature (/ (* 2 (cos θ)) (* a '(+ (* a (cos θ)) b))))  ;; ;; Covariant derivative of Riemann curvature tensor@@ -115,12 +116,14 @@        (. Γ~n_m_k R_i_j_n_l)        (. Γ~n_m_l R_i_j_k_n)))) -∇R_#_#_#_#_#-;(tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 (+ (* -1 a '(+ (* a (cos θ)) b) (sin θ)) (* a^2 (sin θ) (cos θ))) 0 (+ (* a '(+ (* a (cos θ)) b) (sin θ)) (* -1 a^2 (sin θ) (cos θ))) 0 0 0 0 0 (+ (* '(+ (* a (cos θ)) b) a (sin θ)) (* -1 a^2 (sin θ) (cos θ))) 0 (+ (* -1 '(+ (* a (cos θ)) b) a (sin θ)) (* a^2 (sin θ) (cos θ))) 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#_#+(assert-equal "Covariant derivative of Riemann curvature tensor"+  ∇R_#_#_#_#_#+  (tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 (+ (* -1 a '(+ (* a (cos θ)) b) (sin θ)) (* a^2 (sin θ) (cos θ))) 0 (+ (* a '(+ (* a (cos θ)) b) (sin θ)) (* -1 a^2 (sin θ) (cos θ))) 0 0 0 0 0 (+ (* '(+ (* a (cos θ)) b) a (sin θ)) (* -1 a^2 (sin θ) (cos θ))) 0 (+ (* -1 '(+ (* a (cos θ)) b) a (sin θ)) (* a^2 (sin θ) (cos θ))) 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#_#)  ;; ;; Second Bianchi identity ;; -(with-symbols {i j k l m} (+ ∇R_i_j_k_l_m ∇R_i_j_l_m_k ∇R_i_j_m_k_l))-;(tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )+(assert-equal "Second Bianchi identity"+  (with-symbols {i j k l m} (+ ∇R_i_j_k_l_m ∇R_i_j_l_m_k ∇R_i_j_m_k_l))+  (tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} ))

@@ -63,14 +63,7 @@  (define $a1' (/ (+ b11' b12') 2)) -a1';(+ z z^16) = (* 2 (cos (/ (* 2 pi) 17)))-;(/ (+ -1 (sqrt 17) (sqrt (+ 34 (* -2 (sqrt 17)))) (* 2 (sqrt (+ 17 (* 3 (sqrt 17)) (* -1 (sqrt (+ 34 (* -2 (sqrt 17))))) (* -2 (sqrt (+ 34 (* 2 (sqrt 17))))))))) 8)--(/ (+ -1-      (sqrt 17)-      (sqrt (+ 34 (* -2 (sqrt 17))))-      (* 2 (sqrt (+ 17-                    (* 3 (sqrt 17))-                    (* -1 (sqrt (+ 34 (* -2 (sqrt 17)))))-                    (* -2 (sqrt (+ 34 (* 2 (sqrt 17)))))))))-   8)+(assert-equal "17th-root-of-unity"+  a1';(+ z z^16) = (* 2 (cos (/ (* 2 pi) 17)))+  (/ (+ -1 (sqrt 17) (sqrt (+ 34 (* -2 (sqrt 17)))) (* 2 (sqrt (+ 17 (* 3 (sqrt 17)) (* -1 (sqrt (+ 34 (* -2 (sqrt 17))))) (* -2 (sqrt (+ 34 (* 2 (sqrt 17))))))))) 8)+  )

@@ -1,5 +1,5 @@ (define $nishiwaki-if-  (macro [$b $e1 $e2]+  (lambda [$b $e1 $e2]     (car (match-all b (matcher {[$ something {[#t {e1}] [#f {e2}]}]})            [$x x])))) 

@@ -23,14 +23,14 @@ import           Language.Egison.Types  main :: IO ()-main = do-  let unitTests     = map runUnitTestCase     unitTestCases-      unitNonSTests = map runUnitTestCaseNonS unitNonSTestCases-      sampleTests   = map runSampleTestCase   sampleTestCases-   in defaultMain . hUnitTestToTests . test $ unitNonSTests ++ unitTests ++ sampleTests+main =+  defaultMain . hUnitTestToTests . test $ nonSTests ++ sExprTests+  where+    sExprTests = map runTestCase     testCases+    nonSTests  = map runTestCaseNonS nonSTestCases -unitTestCases :: [FilePath]-unitTestCases =+testCases :: [FilePath]+testCases =   [ "test/syntax.egi"   , "test/primitive.egi"   , "test/lib/math/analysis.egi"@@ -43,28 +43,31 @@   , "test/lib/core/order.egi"   , "test/lib/core/number.egi" -  , "sample/mahjong.egi"-  , "sample/poker-hands-with-joker.egi"   , "sample/poker-hands.egi"-  , "sample/primes.egi"+  , "sample/poker-hands-with-joker.egi"+  , "sample/mahjong.egi" -- for testing pattern functions+  , "sample/primes.egi" -- for testing pattern matching with infinitely many results+  , "sample/sat/cdcl.egi" -- for testing a practical program using pattern matching+  , "sample/math/number/17th-root-of-unity.egi" -- for testing rewriting of mathematical expressions+  , "sample/math/geometry/riemann-curvature-tensor-of-S2.egi" -- for testing tensor index notation+  , "sample/math/geometry/riemann-curvature-tensor-of-T2.egi" -- for testing tensor index notation and math quote+  , "sample/math/geometry/curvature-form.egi" -- for testing differential form+  , "sample/math/geometry/hodge-laplacian-polar.egi" -- for testing "..." in tensor indices   ] -unitNonSTestCases :: [FilePath]-unitNonSTestCases =+nonSTestCases :: [FilePath]+nonSTestCases =   [ "nons-test/test/syntax.egi"   , "nons-test/test/primitive.egi"   , "nons-test/test/lib/core/base.egi"   , "nons-test/test/lib/core/order.egi"-  ] -sampleTestCases :: [FilePath]-sampleTestCases =-  [ "test/answer/sample/math/geometry/riemann-curvature-tensor-of-S2.egi"-  , "test/answer/sample/math/number/17th-root-of-unity.egi"+  , "nons-sample/math/geometry/curvature-form.egi"+  , "nons-sample/math/geometry/hodge-laplacian-polar.egi" -- for testing "..." in tensor indices   ] -runUnitTestCase :: FilePath -> Test-runUnitTestCase file = TestLabel file . TestCase $ do+runTestCase :: FilePath -> Test+runTestCase file = TestLabel file . TestCase $ do   env <- initialEnv defaultOption   assertEgisonM $ do     exprs <- Parser.loadFile file@@ -75,8 +78,8 @@     assertEgisonM :: EgisonM a -> Assertion     assertEgisonM m = fromEgisonM m >>= assertString . either show (const "") -runUnitTestCaseNonS :: FilePath -> Test-runUnitTestCaseNonS file = TestLabel file . TestCase $ do+runTestCaseNonS :: FilePath -> Test+runTestCaseNonS file = TestLabel file . TestCase $ do   env <- initialEnv (defaultOption { optSExpr = False })   assertEgisonM $ do     exprs <- ParserNonS.loadFile file@@ -86,29 +89,6 @@   where     assertEgisonM :: EgisonM a -> Assertion     assertEgisonM m = fromEgisonM m >>= assertString . either show (const "")--runSampleTestCase :: FilePath -> Test-runSampleTestCase file = TestLabel file . TestCase $ do-  env <- initialEnv defaultOption-  let directory_path = takeDirectory file-  answers <- readFile file-  assertEgisonM (lines answers) $ do-    exprs <- Parser.loadFile (replaceDirectory file $ concat $ drop 2 $ splitPath directory_path)-    let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs-    env' <- recursiveBind env bindings-    vals <- forM tests (evalExprDeep env')-    return $ zip tests vals-  where-    assertEgisonM :: [String] -> EgisonM [(EgisonExpr, EgisonValue)] -> Assertion-    assertEgisonM answers m = fromEgisonM m >>= assertString . either show (f answers)--    f :: [String] -> [(EgisonExpr, EgisonValue)] -> String-    f answers ls = g answers ls 0-    g x y i = let (e, v) = unzip y in-              if (x !! i) == prettyS (v !! i)-                 then (if i < (length y - 1) then g x y (i + 1)-                                             else "")-                 else "failed " ++ show (e !! i) ++ "\n expected: " ++ (x !! i) ++ "\n but found: " ++ prettyS (v !! i)  collectDefsAndTests :: EgisonTopExpr -> ([(Var, EgisonExpr)], [EgisonExpr]) -> ([(Var, EgisonExpr)], [EgisonExpr]) collectDefsAndTests (Define name expr) (bindings, tests) =

@@ -1,23 +0,0 @@-[| [| (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |] [| (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |] |]_i_j-[| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |]_#_#-[| [| (/ 1 r^2) 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) |] |]~#~#-(tensor {2 2 2} {0 0 0 (* -1 r^2 (sin θ) (cos θ)) 0 (* r^2 (sin θ) (cos θ)) (* r^2 (sin θ) (cos θ)) 0} )_#_#_#-[| [| 0 0 |] [| 0 (* -1 r^2 (sin θ) (cos θ)) |] |]_#_#-[| [| 0 (* r^2 (sin θ) (cos θ)) |] [| (* r^2 (sin θ) (cos θ)) 0 |] |]_#_#-(tensor {2 2 2} {0 0 0 (* -1 (sin θ) (cos θ)) 0 (/ (cos θ) (sin θ)) (/ (cos θ) (sin θ)) 0} )~#_#_#-[| [| 0 0 |] [| 0 (* -1 (sin θ) (cos θ)) |] |]_#_#-[| [| 0 (/ (cos θ) (sin θ)) |] [| (/ (cos θ) (sin θ)) 0 |] |]_#_#-(tensor {2 2 2} {0 0 0 0 0 0 0 0} )_#_#_#-(tensor {2 2 2 2} {0 0 0 0 0 (sin θ)^2 (* -1 (sin θ)^2) 0 0 -1 1 0 0 0 0 0} )~#_#_#_#-[| [| 0 0 |] [| 0 0 |] |]~#_#-[| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_#-[| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_#-[| [| 0 0 |] [| 0 0 |] |]~#_#-(tensor {2 2 2 2} {0 0 0 0 0 (* r^2 (sin θ)^2) (* -1 r^2 (sin θ)^2) 0 0 (* -1 r^2 (sin θ)^2) (* r^2 (sin θ)^2) 0 0 0 0 0} )_#_#_#_#-[| [| 0 0 |] [| 0 0 |] |]_#_#-[| [| 0 (* r^2 (sin θ)^2) |] [| (* -1 r^2 (sin θ)^2) 0 |] |]_#_#-[| [| 0 (* -1 r^2 (sin θ)^2) |] [| (* r^2 (sin θ)^2) 0 |] |]_#_#-[| [| 0 0 |] [| 0 0 |] |]_#_#-[| [| 1 0 |] [| 0 (sin θ)^2 |] |]_#_#-(/ 2 r^2)-(tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#_#

@@ -1,2 +0,0 @@-(/ (+ -1 (sqrt 17) (* (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* 2 (sqrt (+ 17 (* 3 (sqrt 17)) (* -1 (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* -2 (sqrt 2) (sqrt (+ 17 (sqrt 17)))))))) 8)-(/ (+ -1 (sqrt 17) (* (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* 2 (sqrt (+ 17 (* 3 (sqrt 17)) (* -1 (sqrt 2) (sqrt (+ 17 (* -1 (sqrt 17))))) (* -2 (sqrt 2) (sqrt (+ 17 (sqrt 17)))))))) 8)

@@ -20,19 +20,20 @@  (assert-equal "tailor-expansion - case 1"   (take 4 (taylor-expansion (** e (* i x)) x 0))-  {1 (* i x) (/ (* -1 x^2) 2) (/ (* -1 i x^3) 6)})+  {(`exp 0) (* (`exp 0) i x) (/ (* -1 (`exp 0) x^2) 2) (/ (* -1 (`exp 0) i x^3) 6)})+;  {1 (* i x) (/ (* -1 x^2) 2) (/ (* -1 i x^3) 6)}) -(assert-equal "tailor-expansion - case 2"-  (take 4 (taylor-expansion (* i (sin x)) x 0))-  {0 (* i x) 0 (/ (* -1 i x^3) 6)})+;(assert-equal "tailor-expansion - case 2"+;  (take 4 (taylor-expansion (* i (sin x)) x 0))+;  {0 (* i x) 0 (/ (* -1 i x^3) 6)}) -;(assert-equal "multivariate-tailor-expansion - case 1"-;  (take 3 (multivariate-taylor-expansion (f x y) [| x y |] [| 0 0 |]))-;  {(f 0 0) (+ (* x (f|1 0 0)) (* y (f|2 0 0))) (/ (+ (* x^2 (f|1|1 0 0)) (* 2 x y (f|1|2 0 0)) (* y^2 (f|2|2 0 0))) 2)})+(assert-equal "multivariate-tailor-expansion - case 1"+  (take 3 (multivariate-taylor-expansion (f x y) [| x y |] [| 0 0 |]))+  {(f 0 0) (+ (* x (f|1 0 0)) (* y (f|2 0 0))) (/ (+ (* x^2 (f|1|1 0 0)) (* x y (f|1|2 0 0)) (* x y (f|2|1 0 0)) (* y^2 (f|2|2 0 0))) 2)}) -(assert-equal "multivariate-tailor-expansion - case 2"-  (take 3 (multivariate-taylor-expansion (** e (+ x y)) [| x y |] [| 0 0 |]))-  {1 (+ x y) (/ (+ x^2 (* 2 x y) y^2) 2)})+;(assert-equal "multivariate-tailor-expansion - case 2"+;  (take 3 (multivariate-taylor-expansion (** e (+ x y)) [| x y |] [| 0 0 |]))+;  {1 (+ x y) (/ (+ x^2 (* 2 x y) y^2) 2)})  (assert-equal "function expr"   (let {[$f (function [x y])]}

@@ -65,10 +65,10 @@ ;  [|(f|1 x y) (f|2 x y)|])  (assert-equal "append indices with ..."-  (show (let {[$A (generate-tensor 2#1 {2 2})]-              [$f (lambda [%B] B..._j)]}-          (f A_i)))-  (show [| [| 1 1 |] [| 1 1 |] |]_i_j))+  (let {[$A (generate-tensor 2#1 {2 2})]+        [$f (lambda [%B] B..._j)]}+    (f A_i))+  [| [| 1 1 |] [| 1 1 |] |]_i_j)  (assert-equal "generate_tensor by using function expr"   (letrec {[$g__ (generate-tensor

@@ -196,11 +196,6 @@     [<cons $n !<cons ,n _>> n])   {1}) -(assert-equal "later pattern"-  (match-all {1 1 2} (list integer)-    [<cons (later ,n) <cons $n _>> n])-  {1})- (assert "predicate pattern"   (match {1 2 3} (list integer)     {[<cons ?(eq? 1 $) _> #t]}))