egison 3.6.0 → 3.6.1

raw patch · 30 files changed

+2133/−1071 lines, 30 filesdep +vectorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: vector

API changes (from Hackage documentation)

Files

• egison.cabal +5/−5
• elisp/egison-mode.el +17/−2
• hs-src/Interpreter/egison.hs +1/−1
• hs-src/Language/Egison.hs +3/−0
• hs-src/Language/Egison/Core.hs +356/−155
• hs-src/Language/Egison/Desugar.hs +95/−19
• hs-src/Language/Egison/Parser.hs +115/−40
• hs-src/Language/Egison/Primitives.hs +163/−113
• hs-src/Language/Egison/Types.hs +575/−242
• lib/core/assoc.egi +10/−10
• lib/core/base.egi +9/−6
• lib/core/collection.egi +28/−11
• lib/core/io.egi +15/−7
• lib/core/number.egi +1/−1
• lib/core/shell.egi +1/−1
• lib/core/string.egi +4/−4
• lib/math/algebra/equations.egi +11/−11
• lib/math/algebra/inverse.egi +10/−8
• lib/math/algebra/matrix.egi +145/−0
• lib/math/algebra/root.egi +45/−20
• lib/math/algebra/tensor.egi +17/−143
• lib/math/algebra/vector.egi +28/−0
• lib/math/analysis/derivative.egi +49/−42
• lib/math/analysis/integral.egi +31/−39
• lib/math/common/arithmetic.egi +48/−20
• lib/math/common/constants.egi +7/−0
• lib/math/common/functions.egi +20/−14
• lib/math/expression.egi +160/−107
• lib/math/normalize.egi +163/−49
• test/UnitTest.hs +1/−1

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.6.0+Version:             3.6.1 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.@@ -68,7 +68,7 @@   location: https://github.com/egison/egison.git    Library-  Build-Depends:   base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process+  Build-Depends:   base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process, vector   Hs-Source-Dirs:  hs-src   Exposed-Modules:                    Language.Egison@@ -79,7 +79,7 @@                    Language.Egison.Primitives                    Language.Egison.Util   Other-modules:   Paths_egison-  ghc-prof-options:   -prof -auto-all+  ghc-prof-options:   --enable-profiling -auto-all  Test-Suite test   Type:           exitcode-stdio-1.0@@ -97,8 +97,8 @@  Executable egison   Main-is:             egison.hs-  Build-depends:       egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, text, regex-tdfa, process+  Build-depends:       egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, text, regex-tdfa, process, vector   Hs-Source-Dirs:      hs-src/Interpreter   Other-modules:       Paths_egison   ghc-options:  -rtsopts -threaded-  ghc-prof-options:   -prof -auto-all+  ghc-prof-options:   --enable-profiling -auto-all

@@ -40,6 +40,8 @@     (list      "\\<module\\>"      "\\<define\\>"+     "\\<redefine\\>"+     "\\<set!\\>"      "\\<test\\>"      "\\<execute\\>"      "\\<load\\>"@@ -49,16 +51,23 @@      "\\<memoized-lambda\\>"      "\\<memoize\\>"      "\\<cambda\\>"+     "\\<procedure\\>"      "\\<macro\\>"      "\\<let\\>"      "\\<letrec\\>"      "\\<let\\*\\>"+     "\\<with-symbols\\>"      "\\<if\\>"      "\\<seq\\>" ;     "\\<apply\\>"+     "\\<capply\\>"      "\\<generate-array\\>"      "\\<array-bounds\\>"      "\\<array-ref\\>"+     "\\<tensor\\>"+     "\\<generate-tensor\\>"+     "\\<contract\\>"+     "\\<tensor-map\\>"       "\\<loop\\>"      "\\<match\\>"@@ -86,12 +95,14 @@            "\\\.\\\.\\\."      "\\\,"+;     "'"+     "`"      "\\\#"      "|"      "\\\&"      "@"      "!"-     "\\<_\\>"+;     "\\<_\\>"       "\\<assert\\>"      "\\<assert-equal\\>"@@ -174,17 +185,21 @@         ((equal "execute" name) 2)         ((equal "lambda" name) 2)         ((equal "cambda" name) 2)+        ((equal "procedure" name) 2)         ((equal "macro" name) 2)         ((equal "memoized-lambda" name) 2)         ((equal "memoize" name) 2)         ((equal "letrec" name) 2)         ((equal "let" name) 2)         ((equal "let*" name) 2)+        ((equal "with-symbols" name) 2)         ((equal "if" name) 2)         ((equal "apply" name) 2)         ((equal "generate-array" name) 2)         ((equal "array-size" name) 2)         ((equal "array-ref" name) 2)+        ((equal "generate-tensor" name) 2)+        ((equal "tensor-map" name) 2)         ((equal "loop" name) 2)         ((equal "match" name) 2)         ((equal "match-lambda" name) 2)@@ -236,7 +251,7 @@   (set (make-local-variable 'font-lock-defaults)        '((egison-font-lock-keywords           egison-font-lock-keywords-1 egison-font-lock-keywords-2)-         nil t (("+-*/=?%:_.'" . "w") ("<" . "(") (">" . ")"))+         nil t (("+-*/=!?%:_~.'∂∇α-ωΑ-Ω" . "w") ("<" . "(") (">" . ")"))          ))   (set (make-local-variable 'indent-line-function) 'egison-indent-line)   (set (make-local-variable 'comment-start) ";")

@@ -217,7 +217,7 @@ showBanner :: IO () showBanner = do   putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2016 Satoshi Egi"-  putStrLn $ "http://www.egison.org"+  putStrLn $ "https://www.egison.org"   putStrLn $ "Welcome to Egison Interpreter!" --  putStrLn $ "** Information **" --  putStrLn $ "We can use the tab key to complete keywords on the interpreter."

@@ -108,12 +108,15 @@   [ "lib/math/expression.egi"   , "lib/math/normalize.egi"   , "lib/math/common/arithmetic.egi"+  , "lib/math/common/constants.egi"   , "lib/math/common/functions.egi"   , "lib/math/algebra/root.egi"   , "lib/math/algebra/equations.egi"   , "lib/math/algebra/inverse.egi"   , "lib/math/analysis/derivative.egi"   , "lib/math/analysis/integral.egi"+  , "lib/math/algebra/vector.egi"+  , "lib/math/algebra/matrix.egi"   , "lib/math/algebra/tensor.egi"   , "lib/core/base.egi"   , "lib/core/collection.egi"

@@ -58,6 +58,7 @@ import qualified Data.HashMap.Lazy as HL import Data.Array ((!)) import qualified Data.Array as Array+import qualified Data.Vector as V import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -81,7 +82,7 @@   collectDefs :: [EgisonTopExpr] -> [(String, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(String, EgisonExpr)], [EgisonTopExpr])   collectDefs (expr:exprs) bindings rest =     case expr of-      Define name expr -> collectDefs exprs ((name, expr) : bindings) rest+      Define name expr -> collectDefs exprs ((show name, expr) : bindings) rest       Load file -> do         exprs' <- loadLibraryFile file         collectDefs (exprs' ++ exprs) bindings rest@@ -102,7 +103,7 @@   collectDefs :: [EgisonTopExpr] -> [(String, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(String, EgisonExpr)], [EgisonTopExpr])   collectDefs (expr:exprs) bindings rest =     case expr of-      Define name expr -> collectDefs exprs ((name, expr) : bindings) rest+      Define name expr -> collectDefs exprs ((show name, expr) : bindings) rest       Load file -> do         exprs' <- loadLibraryFile file         collectDefs (exprs' ++ exprs) bindings rest@@ -110,6 +111,7 @@         exprs' <- loadFile file         collectDefs (exprs' ++ exprs) bindings rest       Test _ -> collectDefs exprs bindings (expr : rest)+      Redefine _ _ -> collectDefs exprs bindings (expr : rest)       _ -> collectDefs exprs bindings rest   collectDefs [] bindings rest = return (bindings, reverse rest) @@ -123,7 +125,7 @@   collectDefs :: [EgisonTopExpr] -> [(String, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(String, EgisonExpr)], [EgisonTopExpr])   collectDefs (expr:exprs) bindings rest =     case expr of-      Define name expr -> collectDefs exprs ((name, expr) : bindings) rest+      Define name expr -> collectDefs exprs ((show name, expr) : bindings) rest       Load _ -> throwError $ strMsg "No IO support"       LoadFile _ -> throwError $ strMsg "No IO support"       _ -> collectDefs exprs bindings (expr : rest)@@ -138,7 +140,8 @@   return $ snd ret  evalTopExpr' :: Env -> EgisonTopExpr -> EgisonM (Maybe String, Env)-evalTopExpr' env (Define name expr) = recursiveBind env [(name, expr)] >>= return . ((,) Nothing)+evalTopExpr' env (Define name expr) = recursiveBind env [(show name, expr)] >>= return . ((,) Nothing)+evalTopExpr' env (Redefine name expr) = recursiveRebind env (show name, expr) >>= return . ((,) Nothing) evalTopExpr' env (Test expr) = do   val <- evalExprDeep env expr   return (Just (show val), env)@@ -157,12 +160,26 @@ evalExpr _ (IntegerExpr x) = return . Value $ toEgison x evalExpr _ (FloatExpr x y) = return . Value $ Float x y +evalExpr env (QuoteExpr expr) = do+  whnf <- evalExpr env expr+  case whnf of+    Value (ScalarData s) -> return . Value $ ScalarData $ Div (Plus [Term 1 [(Quote s, 1)]]) (Plus [Term 1 []])+    _ -> throwError $ TypeMismatch "scalar in quote" $ whnf++evalExpr env (QuoteFunctionExpr expr) = do+  whnf <- evalExpr env expr+  case whnf of+    Value val -> return . Value $ QuotedFunc val+    _ -> throwError $ TypeMismatch "value in quote-function" $ whnf+ evalExpr env (VarExpr name) = refVar' env name >>= evalRef  where-  refVar' :: Env -> Var -> EgisonM ObjectRef-  refVar' env var = maybe (newEvalutedObjectRef (Value (symbolScalarData var []))) return+  refVar' :: Env -> String -> EgisonM ObjectRef+  refVar' env var = maybe (newEvaluatedObjectRef (Value (symbolScalarData "" var))) return                           (refVar env var) +evalExpr env (PartialVarExpr n) = evalExpr env (VarExpr ("::" ++ show n))+ evalExpr _ (InductiveDataExpr name []) = return . Value $ InductiveData name [] evalExpr env (InductiveDataExpr name exprs) =   Intermediate . IInductiveData name <$> mapM (newObjectRef env) exprs @@ -186,33 +203,27 @@   refs' <- mapM (newObjectRef env) exprs   return . Intermediate . IArray $ Array.listArray (1, toInteger (length exprs)) refs' -evalExpr env (TensorExpr nsExpr xsExpr) = do-  nsWhnf <- evalExpr env nsExpr-  ns <- ((fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer])-  xsWhnf <- evalExpr env xsExpr-  xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef >>= mapM toScalarData-  if product ns == toInteger (length xs)-    then return $ Value $ TensorData (makeTensor ns xs Nothing)-    else throwError $ InconsistentTensorSize- where-  toScalarData :: WHNFData -> EgisonM ScalarData-  toScalarData (Value (ScalarData x)) = return x-  toScalarData val = throwError $ TypeMismatch "integer or string" $ val+evalExpr env (VectorExpr exprs) = do+  whnfs <- mapM (evalExpr env) exprs+  case whnfs of+    [whnf] -> return $ whnf+    ((Intermediate (ITensor (Tensor _ _ _))):_) -> do+      mapM toTensor whnfs >>= tConcat' >>= fromTensor+    _ -> do+      fromTensor (Tensor [fromIntegral (length whnfs)] (V.fromList whnfs) []) -evalExpr env (InitTensorExpr nsExpr xsExpr jsExpr) = do+evalExpr env (TensorExpr nsExpr xsExpr supExpr subExpr) = do   nsWhnf <- evalExpr env nsExpr   ns <- ((fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer])   xsWhnf <- evalExpr env xsExpr-  xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef >>= mapM toScalarData-  jsWhnf <- evalExpr env jsExpr-  js <- fromCollection jsWhnf >>= fromMList >>= mapM evalRef >>= mapM toScalarData+  xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef+  supWhnf <- evalExpr env supExpr+  sup <- fromCollection supWhnf >>= fromMList >>= mapM evalRefDeep -- >>= mapM extractScalar'+  subWhnf <- evalExpr env subExpr+  sub <- fromCollection subWhnf >>= fromMList >>= mapM evalRefDeep -- >>= mapM extractScalar'   if product ns == toInteger (length xs)-    then return $ Value $ TensorData (makeTensor ns xs (Just js))+    then fromTensor (initTensor ns xs sup sub)     else throwError $ InconsistentTensorSize- where-  toScalarData :: WHNFData -> EgisonM ScalarData-  toScalarData (Value (ScalarData x)) = return x-  toScalarData val = throwError $ TypeMismatch "integer or string" $ val  evalExpr env (HashExpr assocs) = do   let (keyExprs, exprs) = unzip assocs@@ -245,30 +256,61 @@   makeHashKey whnf = throwError $ TypeMismatch "integer or string" $ whnf  evalExpr env (IndexedExpr expr indices) = do-  tensor <- evalExpr env expr-  indices' <- mapM (evalExprDeep env) indices+  tensor <- case expr of+              (VarExpr var) -> do+                let mObjRef = refVar env (show (Var var (map f indices)))+                case mObjRef of+                  (Just objRef) -> evalRef objRef+                  Nothing -> evalExpr env expr+              _ -> evalExpr env expr+  js <- mapM (\i -> case i of+                      Superscript n -> evalExprDeep env n >>= return . Superscript+                      Subscript n -> evalExprDeep env n >>= return . Subscript+                      SupSubscript n -> evalExprDeep env n >>= return . SupSubscript+              ) indices   case tensor of-    (Value (ScalarData (Div (Plus [(Term 1 [(Symbol name [], 1)])]) (Plus [(Term 1 [])])))) -> do-      js <- (mapM fromEgison indices') :: EgisonM [Integer]-      return $ Value (ScalarData (Div (Plus [(Term 1 [(Symbol name js, 1)])]) (Plus [(Term 1 [])])))-    (Value (TensorData (TData (Tensor ns xs) _))) -> do-      indices'' <- mapM extract indices'-      tCheckIndex indices'' ns-      if all (\x -> isInteger x) indices'-        then do indices'' <- ((mapM fromEgison indices') :: EgisonM [Integer])-                return $ Value $ ScalarData (tref' indices'' (Tensor ns xs))-        else do ret <- tContract (TData (tref indices'' (Tensor ns xs)) (Just (filter (isSymbol . ScalarData) indices'')))-                return $ Value ret-    _ -> refArray tensor indices'+    (Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name [], 1)])]) (Plus [(Term 1 [])])))) -> do+      js2 <- mapM (\i -> case i of+                           Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript+                           Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript+                           SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript+                  ) indices+      return $ Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name js2, 1)])]) (Plus [(Term 1 [])])))+    (Value (ScalarData _)) -> do+      return $ tensor+    (Value (TensorData (Tensor ns xs _))) -> do+      tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value+    (Intermediate (ITensor (Tensor ns xs _))) -> do+      tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor+    _ -> do+      js2 <- mapM (\i -> case i of+                           Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript+                           Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript+                           SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript+                  ) indices+      refArray tensor (map (\j -> case j of+                                    Superscript k -> ScalarData k+                                    Subscript k -> ScalarData k+                                    SupSubscript k -> ScalarData k+                            ) js2)  where-  extract :: EgisonValue -> EgisonM ScalarData-  extract (ScalarData s) = return s-  extract val = throwError $ TypeMismatch "scalar expression" (Value val)+  f :: Index a -> Index ()+  f (Superscript _) = Superscript ()+  f (Subscript _) = Subscript ()+  f (SupSubscript _) = SupSubscript () -evalExpr env (LambdaExpr names expr) = return . Value $ Func Nothing env names expr+evalExpr env (LambdaExpr names expr) = do+  names' <- mapM (\name -> case name of+                             (TensorArg name') -> return name'+                             (ScalarArg _) -> throwError $ EgisonBug "scalar-arg remained") names+  return . Value $ Func Nothing env names' expr +evalExpr env (PartialExpr n expr) = return . Value $ PartialFunc env n expr+ evalExpr env (CambdaExpr name expr) = return . Value $ CFunc Nothing env name expr +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@@ -306,6 +348,73 @@   genVar :: State Int String   genVar = modify (1+) >> gets (('#':) . show) +evalExpr env (WithSymbolsExpr vars expr) = do+  symId <- fresh+  syms <- mapM (\var -> (newEvaluatedObjectRef (Value (symbolScalarData symId var)))) vars+  let bindings = zip vars syms+  whnf <- evalExpr (extendEnv env bindings) expr+  case whnf of+    (Value val) -> removeVarsFromIndices symId val >>= return . Value+    (Intermediate (ITensor (Tensor ns xs js))) -> do+      js' <- removeVars symId (tClearIndex' js)+      return (Intermediate (ITensor (Tensor ns xs js')))+    _ -> return whnf+ where+  removeVarsFromIndices :: String -> EgisonValue -> EgisonM EgisonValue+  removeVarsFromIndices symId (TensorData (Tensor ns xs js)) = do+    xs' <- mapM (removeVarsFromIndices symId) xs+    js' <- removeVars symId (tClearIndex' js)+    fromTensor (Tensor ns xs' js')+  removeVarsFromIndices symId (ScalarData s) = f symId s >>= return . ScalarData+  removeVarsFromIndices _ val = return val+  f :: String -> ScalarData -> EgisonM ScalarData+  f symId (Div (Plus ts1) (Plus ts2)) = do+    ts1' <- mapM (g symId) ts1+    ts2' <- mapM (g symId) ts2+    return (Div (Plus ts1') (Plus ts2'))+  g :: String -> TermExpr -> EgisonM TermExpr+  g symId (Term a xns) = do+    let (xs, ns) = unzip xns+    xs' <- mapM (h symId) xs+    return (Term a (zip xs' ns))+  h :: String -> SymbolExpr -> EgisonM SymbolExpr+  h symId (Symbol id name js) = do+    js' <- removeVars symId (map (\j -> case j of+                                          Superscript i -> Superscript (ScalarData i)+                                          Subscript i -> Subscript (ScalarData i)+                                          SupSubscript i -> SupSubscript (ScalarData i)+                                  )js)+    let js'' = map (\j -> case j of+                            Superscript (ScalarData i) -> Superscript i+                            Subscript (ScalarData i) -> Subscript i+                            SupSubscript (ScalarData i) -> SupSubscript i+                    ) js'+    return (Symbol id name js'')+  h symId (Apply fn xs) = do+    xs' <- mapM (f symId) xs+    return (Apply fn xs')+  h symId (Quote x) = do+    x' <- f symId x+    return (Quote x')+  removeVars :: String -> [Index EgisonValue] -> EgisonM [Index EgisonValue]+  removeVars _ [] = return []+  removeVars symId ((Subscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js)+    | symId == id = return []+    | otherwise = do js' <- removeVars symId js+                     return $ (Subscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js'+  removeVars symId ((Superscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js)+    | symId == id = return []+    | otherwise = do js' <- removeVars symId js+                     return $ (Superscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js'+  removeVars symId ((SupSubscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js)+    | symId == id = return []+    | otherwise = do js' <- removeVars symId js+                     return $ (SupSubscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js'+  removeVars symId (j:js) = do+    js' <- removeVars symId js+    return $ j:js'+    + evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do   let body = foldr genLet (ApplyExpr expr $ TupleExpr [VarExpr "#1"]) bindings   applyFunc env (Value $ Func Nothing env ["#1"] body) $ Value World@@ -324,7 +433,7 @@     _ -> throwError $ TypeMismatch "io" io  evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do-  target <- newObjectRef env target+  target <- evalExpr env target   matcher <- evalExpr env matcher >>= evalMatcherWHNF   result <- patternMatch env pattern target matcher   mmap (flip evalExpr expr . extendEnv env) result >>= fromMList@@ -332,20 +441,23 @@   fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData   fromMList MNil = return . Value $ Collection Sq.empty   fromMList (MCons val m) = do-    head <- IElement <$> newEvalutedObjectRef val+    head <- IElement <$> newEvaluatedObjectRef val     tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList)     seqRef <- liftIO . newIORef $ Sq.fromList [head, tail]     return . Intermediate $ ICollection $ seqRef  evalExpr env (MatchExpr target matcher clauses) = do-  target <- newObjectRef env target+  target <- evalExpr env target   matcher <- evalExpr env matcher >>= evalMatcherWHNF-  let tryMatchClause (pattern, expr) cont = do-        result <- patternMatch env pattern target matcher-        case result of-          MCons bindings _ -> evalExpr (extendEnv env bindings) expr-          MNil -> cont-  foldr tryMatchClause (throwError $ strMsg "failed pattern match") clauses+  f matcher target+ where+  f matcher target = do+      let tryMatchClause (pattern, expr) cont = do+            result <- patternMatch env pattern target matcher+            case result of+              MCons bindings _ -> evalExpr (extendEnv env bindings) expr+              MNil -> cont+      foldr tryMatchClause (throwError $ strMsg "failed pattern match") clauses  evalExpr env (SeqExpr expr1 expr2) = do   evalExprDeep env expr1@@ -363,7 +475,7 @@           evalRef objRef         Nothing -> do           whnf <- applyFunc env (Value (Func Nothing env names body)) (Value (makeTuple args))-          retRef <- newEvalutedObjectRef whnf+          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))@@ -374,6 +486,10 @@   func <- evalExpr env func   arg <- evalExpr env arg   case func of+    Value (TensorData t@(Tensor ns fs js)) -> do+      tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor >>= return . Value+    Intermediate (ITensor t@(Tensor ns fs js)) -> do+      tMap (\f -> applyFunc env f arg) t >>= fromTensor     Value (MemoizedFunc name ref hashRef env names body) -> do       indices <- evalWHNF arg       indices' <- mapM fromEgison $ fromTupleValue indices@@ -383,7 +499,7 @@           evalRef objRef         Nothing -> do           whnf <- applyFunc env (Value (Func Nothing env names body)) arg-          retRef <- newEvalutedObjectRef whnf+          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))@@ -398,7 +514,7 @@                              indices' <- mapM fromEgison $ fromTupleValue indices                              hash <- liftIO $ readIORef hashRef                              ret <- evalExprDeep env z-                             retRef <- newEvalutedObjectRef (Value ret)+                             retRef <- newEvaluatedObjectRef (Value ret)                              liftIO $ writeIORef hashRef (HL.insert indices' retRef hash)                              writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body))                            _ -> throwError $ TypeMismatch "memoized-function" (Value x'))@@ -422,42 +538,78 @@   size'' <- collectionToList size'   ns <- (mapM fromEgison size'') :: EgisonM [Integer]   fn <- evalExpr env fnExpr-  xs <-  mapM (\ms -> applyFunc env fn (Value (makeTuple ms)) >>= evalWHNF >>= extractScalar) (map (\ms -> map toEgison ms) (tensorIndices ns))-  return $ Value (TensorData (makeTensor ns xs Nothing))+  xs <-  mapM (\ms -> applyFunc env fn (Value (makeTuple ms))) (map (\ms -> map toEgison ms) (enumTensorIndices ns))+  case (ns, xs) of+    ([1], x:[]) -> return $ x+    _ -> fromTensor (Tensor ns (V.fromList xs) [])++evalExpr env (TensorContractExpr fnExpr tExpr) = do+  fn <- evalExpr env fnExpr+  whnf <- evalExpr env tExpr+  case whnf of+    (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+      ts <- tContract t+      tMapN (\xs -> applyFunc' env fn (Tuple xs)) ts >>= fromTensor >>= return . Value+    _ -> return whnf  where-  extractScalar :: EgisonValue -> EgisonM ScalarData-  extractScalar (ScalarData x) = return x-  extractScalar x = throwError $ TypeMismatch "scalar expression" (Value x)+  applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue+  applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF  evalExpr env (TensorMapExpr fnExpr tExpr) = do   fn <- evalExpr env fnExpr-  tVal <- evalExpr env tExpr-  case tVal of+  whnf <- evalExpr env tExpr+  case whnf of+    Intermediate (ITensor t) -> do+      tMap (applyFunc env fn) t >>= fromTensor     Value (TensorData t) -> do-      tMap (applyScalarFunc env fn) t >>= (return . Value . TensorData)-    _ -> throwError $ TypeMismatch "tensor" tVal+      tMap (applyFunc' env fn) t >>= fromTensor >>= return . Value+    _ -> applyFunc env fn whnf  where-  applyScalarFunc :: Env -> WHNFData -> ScalarData -> EgisonM ScalarData-  applyScalarFunc env fn s = applyFunc env fn (Value (ScalarData s)) >>= extractScalar-  extractScalar :: WHNFData -> EgisonM ScalarData-  extractScalar (Value (ScalarData x)) = return x-  extractScalar x = throwError $ TypeMismatch "scalar expression" x+  applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue+  applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF  evalExpr env (TensorMap2Expr fnExpr t1Expr t2Expr) = do   fn <- evalExpr env fnExpr-  t1Val <- evalExpr env t1Expr-  t2Val <- evalExpr env t2Expr-  case (t1Val, t2Val) of+  whnf1 <- evalExpr env t1Expr+  whnf2 <- evalExpr env t2Expr+  case (whnf1, whnf2) of+    -- both of arguments are tensors+    (Intermediate (ITensor t1), Intermediate (ITensor t2)) -> do+      tMap2 (applyFunc'' env fn) t1 t2 >>= fromTensor+    (Intermediate (ITensor t), Value (TensorData (Tensor ns xs js))) -> do+      let xs' = V.map Value xs+      tMap2 (applyFunc'' env fn) t (Tensor ns xs' js) >>= fromTensor+    (Value (TensorData (Tensor ns xs js)), Intermediate (ITensor t)) -> do+      let xs' = V.map Value xs+      tMap2 (applyFunc'' env fn) (Tensor ns xs' js) t >>= fromTensor     (Value (TensorData t1), Value (TensorData t2)) -> do-      tMap2 (applyScalarFunc env fn) t1 t2 >>= (return . Value . TensorData)-    (Value (TensorData _), _) -> throwError $ TypeMismatch "tensor" t1Val-    _ -> throwError $ TypeMismatch "tensor" t2Val+      tMap2 (\x y -> applyFunc' env fn (Tuple [x, y])) t1 t2 >>= fromTensor >>= return . Value+    -- an argument is scalar+    (Intermediate (ITensor (Tensor ns xs js)), whnf) -> do+      ys <- V.mapM (\x -> (applyFunc'' env fn x whnf)) xs+      return $ Intermediate (ITensor (Tensor ns ys js))+    (whnf, Intermediate (ITensor (Tensor ns xs js))) -> do+      ys <- V.mapM (\x -> (applyFunc'' env fn whnf x)) xs+      return $ Intermediate (ITensor (Tensor ns ys js))+    (Value (TensorData (Tensor ns xs js)), whnf) -> do+      ys <- V.mapM (\x -> (applyFunc'' env fn (Value x) whnf)) xs+      return $ Intermediate (ITensor (Tensor ns ys js))+    (whnf, Value (TensorData (Tensor ns xs js))) -> do+      ys <- V.mapM (\x -> (applyFunc'' env fn whnf (Value x))) xs+      return $ Intermediate (ITensor (Tensor ns ys js))+    _ -> applyFunc'' env fn whnf1 whnf2  where-  applyScalarFunc :: Env -> WHNFData -> ScalarData -> ScalarData -> EgisonM ScalarData-  applyScalarFunc env fn s1 s2 = applyFunc env fn (Value (Tuple [(ScalarData s1), (ScalarData s2)])) >>= extractScalar-  extractScalar :: WHNFData -> EgisonM ScalarData-  extractScalar (Value (ScalarData x)) = return x-  extractScalar x = throwError $ TypeMismatch "scalar expression" x+  applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue+  applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF+  applyFunc'' :: Env -> WHNFData -> WHNFData -> WHNFData -> EgisonM WHNFData+  applyFunc'' env fn x y = do+    xRef <- newEvaluatedObjectRef x+    yRef <- newEvaluatedObjectRef y+    applyFunc env fn (Intermediate (ITuple [xRef, yRef]))  evalExpr _ SomethingExpr = return $ Value Something evalExpr _ UndefinedExpr = return $ Value Undefined@@ -508,17 +660,33 @@   return $ StrHash refs' evalWHNF (Intermediate (ITuple [ref])) = evalRefDeep ref evalWHNF (Intermediate (ITuple refs)) = Tuple <$> mapM evalRefDeep refs+evalWHNF (Intermediate (ITensor (Tensor ns whnfs js))) = do+  vals <- mapM evalWHNF whnfs+  return $ TensorData $ Tensor ns vals js evalWHNF coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList)  applyFunc :: Env -> WHNFData -> WHNFData -> EgisonM WHNFData+applyFunc _ (Value (PartialFunc env n body)) arg = do+  refs <- fromTuple arg+  if n == fromIntegral (length refs)+    then evalExpr (extendEnv env $ makeBindings (map (\n -> "::" ++ show n) [1..n]) refs) body+    else throwError $ ArgumentsNumWithNames ["partial"] (fromIntegral n) (length refs) applyFunc _ (Value (Func _ env [name] body)) arg = do-  ref <- newEvalutedObjectRef arg+  ref <- newEvaluatedObjectRef arg   evalExpr (extendEnv env $ makeBindings [name] [ref]) body applyFunc _ (Value (Func _ env 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)+applyFunc _ (Value (Proc _ env [name] body)) arg = do+  ref <- newEvaluatedObjectRef arg+  evalExpr (extendEnv env $ makeBindings [name] [ref]) body+applyFunc _ (Value (Proc _ env 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) applyFunc _ (Value (CFunc _ env name body)) arg = do   refs <- fromTuple arg   seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs)@@ -527,7 +695,7 @@     then evalExpr (extendEnv env $ makeBindings [name] [col]) body     else throwError $ ArgumentsNumWithNames [name] 1 0 applyFunc env (Value (Macro [name] body)) arg = do-  ref <- newEvalutedObjectRef arg+  ref <- newEvaluatedObjectRef arg   evalExpr (extendEnv env $ makeBindings [name] [ref]) body applyFunc env (Value (Macro names body)) arg = do   refs <- fromTuple arg@@ -539,14 +707,14 @@   case arg of      Value World -> m      _ -> throwError $ TypeMismatch "world" arg-applyFunc _ (Value fn@(ScalarData (Div (Plus [(Term 1 [(Symbol name [], 1)])]) (Plus [(Term 1 [])])))) arg = do+applyFunc _ (Value (QuotedFunc fn)) arg = do   args <- tupleToList arg-  mExprs <- mapM p args+  mExprs <- mapM extractScalar args   return (Value (ScalarData (Div (Plus [(Term 1 [(Apply fn mExprs, 1)])]) (Plus [(Term 1 [])]))))- where-  p :: EgisonValue -> EgisonM ScalarData-  p (ScalarData mExpr) = return mExpr-  p val = throwError $ TypeMismatch "math expression" (Value val)+applyFunc _ (Value fn@(ScalarData (Div (Plus [(Term 1 [(Symbol _ _ _, 1)])]) (Plus [(Term 1 [])])))) arg = do+  args <- tupleToList arg+  mExprs <- mapM extractScalar args+  return (Value (ScalarData (Div (Plus [(Term 1 [(Apply fn mExprs, 1)])]) (Plus [(Term 1 [])])))) applyFunc _ whnf _ = throwError $ TypeMismatch "function" whnf  refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData@@ -558,10 +726,10 @@               then refArray (Value (array ! i)) indices               else return  $ Value Undefined     else case index of-           (ScalarData (Div (Plus [(Term 1 [(Symbol var [], 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 newEvalutedObjectRef elms+             elmRefs <- mapM newEvaluatedObjectRef elms              return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs            _  -> throwError $ TypeMismatch "integer or symbol" (Value index) refArray (Intermediate (IArray array)) (index:indices) = do@@ -572,12 +740,12 @@                    evalRef ref >>= flip refArray indices               else return  $ Value Undefined     else case index of-           (ScalarData (Div (Plus [(Term 1 [(Symbol var [], 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              elms <- mapM (\arr -> refArray arr indices) arrs-             elmRefs <- mapM newEvalutedObjectRef elms+             elmRefs <- mapM newEvaluatedObjectRef elms              return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs            _  -> throwError $ TypeMismatch "integer or symbol" (Value index) refArray (Value (IntHash hash)) (index:indices) = do@@ -629,8 +797,8 @@ writeObjectRef :: ObjectRef -> WHNFData -> EgisonM () writeObjectRef ref val = liftIO . writeIORef ref $ WHNF val -newEvalutedObjectRef :: WHNFData -> EgisonM ObjectRef-newEvalutedObjectRef = liftIO . newIORef . WHNF+newEvaluatedObjectRef :: WHNFData -> EgisonM ObjectRef+newEvaluatedObjectRef = liftIO . newIORef . WHNF  makeBindings :: [String] -> [ObjectRef] -> [Binding] makeBindings = zip@@ -657,11 +825,30 @@             refs bindings   return env' +recursiveRebind :: Env -> (String, EgisonExpr) -> EgisonM Env+recursiveRebind env (name, expr) = do+  case refVar env name of+    Nothing -> throwError $ UnboundVariable name+    Just ref -> case expr of+                  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+                    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+                    whnf <- evalExpr env expr+                    case whnf of+                      (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+ -- -- Pattern Match -- -patternMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher -> EgisonM (MList EgisonM Match) +patternMatch :: Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match)  patternMatch env pattern target matcher = processMStates [msingleton $ MState env [] [] [MAtom pattern target matcher]]  processMStates :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match)@@ -781,7 +968,7 @@          >>= (\b -> return $ msingleton $ MState env loops (b ++ bindings) ((MAtom pattern' target matcher):trees))     PredPat predicate -> do       func <- evalExpr env' predicate-      arg <- evalRef target+      let arg = target       result <- applyFunc env func arg >>= fromWHNF       if result then return $ msingleton $ (MState env loops bindings trees)                 else return MNil@@ -796,26 +983,27 @@      DApplyPat func args -> do       return $ msingleton $ (MState env loops bindings ((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)-      startNumRef <- newEvalutedObjectRef $ Value $ toEgison (startNum - 1)+      startNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum - 1)       ends' <- evalExpr env' ends       if isPrimitiveValue ends'         then do -          endsRef <- newEvalutedObjectRef ends'+          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) bindings ((MAtom ContPat target matcher):trees)         else do-          endsRef <- newEvalutedObjectRef ends'+          endsRef <- newEvaluatedObjectRef ends'           return $ msingleton $ MState env ((LoopPatContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees)     ContPat ->       case loops of         [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern"         LoopPatContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do-          startNum <- evalRef startNumRef >>= fromWHNF :: (EgisonM Integer)-          nextNumRef <- newEvalutedObjectRef $ Value $ toEgison (startNum + 1)+          startNumWhnf <- evalRef startNumRef+          startNum <- fromWHNF startNumWhnf :: (EgisonM Integer)+          nextNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum + 1)           ends <- evalRef endsRef           b <- isEmptyCollection ends           if b@@ -826,7 +1014,7 @@               if startNum > carEndsNum                 then return MNil                 else if startNum == carEndsNum-                       then return $ fromList [MState env loops' bindings ((MAtom endPat startNumRef Something):(MAtom pat' target matcher):trees),+                       then return $ fromList [MState env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees),                                                MState env ((LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)]                        else return $ fromList [MState env ((LoopPatContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)]     AndPat patterns ->@@ -841,7 +1029,7 @@         UserMatcher _ _ _ -> do           (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher           mfor targetss $ \ref -> do-            targets <- evalRef ref >>= fromTuple+            targets <- evalRef ref >>= fromTupleWHNF             let trees' = zipWith3 MAtom patterns targets matchers ++ trees             return $ MState env loops bindings trees'             @@ -852,7 +1040,7 @@             PatVar _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)             IndexedPat _ _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees)             TuplePat patterns -> do-              targets <- evalRef target >>= fromTuple+              targets <- fromTupleWHNF target               if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return ()               if not (length patterns == length matchers) then throwError $ ArgumentsNum (length patterns) (length matchers) else return ()               let trees' = zipWith3 MAtom patterns targets matchers ++ trees@@ -863,32 +1051,35 @@           case pattern of             ValuePat valExpr -> do               val <- evalExprDeep env' valExpr-              tgtVal <- evalRefDeep target+              tgtVal <- evalWHNF target               if val == tgtVal                 then return $ msingleton $ MState env loops bindings trees                 else return MNil             WildCard -> return $ msingleton $ MState env loops bindings trees-            PatVar name -> return $ msingleton $ MState env loops ((name, target):bindings) trees+            PatVar name -> do+              targetRef <- newEvaluatedObjectRef target+              return $ msingleton $ MState env loops ((name, targetRef):bindings) trees             IndexedPat (PatVar name) indices -> do               indices <- mapM (evalExpr env' >=> liftM fromInteger . fromWHNF) indices               case lookup name bindings of                 Just ref -> do-                  obj <- evalRef ref >>= updateHash indices >>= newEvalutedObjectRef+                  obj <- evalRef ref >>= updateHash indices >>= newEvaluatedObjectRef                   return $ msingleton $ MState env loops (subst name obj bindings) trees                 Nothing  -> do-                  obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvalutedObjectRef+                  obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvaluatedObjectRef                   return $ msingleton $ MState env loops ((name,obj):bindings) trees                where                 updateHash :: [Integer] -> WHNFData -> EgisonM WHNFData                 updateHash [index] (Intermediate (IIntHash hash)) = do-                  return . Intermediate . IIntHash $ HL.insert index target hash+                  targetRef <- newEvaluatedObjectRef target+                  return . Intermediate . IIntHash $ HL.insert index targetRef hash                 updateHash (index:indices) (Intermediate (IIntHash hash)) = do                   val <- maybe (return $ Intermediate $ IIntHash HL.empty) evalRef $ HL.lookup index hash-                  ref <- updateHash indices val >>= newEvalutedObjectRef+                  ref <- updateHash indices val >>= newEvaluatedObjectRef                   return . Intermediate . IIntHash $ HL.insert index ref hash                 updateHash indices (Value (IntHash hash)) = do                   keys <- return $ HL.keys hash-                  vals <- mapM (newEvalutedObjectRef . Value) $ HL.elems hash+                  vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash                   updateHash indices (Intermediate $ IIntHash $ HL.fromList $ zip keys vals)                 updateHash _ v = throwError $ strMsg $ "expected hash value: " ++ show v                 subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)]@@ -897,14 +1088,14 @@                 subst _ _ [] = []             IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern)              TuplePat patterns -> do-              targets <- evalRef target >>= fromTuple+              targets <- fromTupleWHNF target               if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return ()               let trees' = zipWith3 MAtom patterns targets (take (length patterns) (repeat Something)) ++ trees               return $ msingleton $ MState env loops bindings trees'             _ -> throwError $ strMsg "something can only match with a pattern variable"         _ ->  throwError $ EgisonBug $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern -inductiveMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher ->+inductiveMatch :: Env -> EgisonPattern -> WHNFData -> Matcher ->                   EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [Matcher]) inductiveMatch env pattern target (UserMatcher matcherEnv _ clauses) = do   foldr tryPPMatchClause failPPPatternMatch clauses@@ -936,54 +1127,57 @@   ref <- lift $ newObjectRef env expr   return ([], [(name, ref)]) primitivePatPatternMatch env (PPInductivePat name patterns) (InductivePat name' exprs)-  | name == name' =+  | name == name' && length patterns == length exprs =     (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs   | otherwise = matchFail primitivePatPatternMatch _ _ _ = matchFail -primitiveDataPatternMatch :: PrimitiveDataPattern -> ObjectRef -> MatchM [Binding]+primitiveDataPatternMatch :: PrimitiveDataPattern -> WHNFData -> MatchM [Binding] primitiveDataPatternMatch PDWildCard _ = return []-primitiveDataPatternMatch (PDPatVar name) ref = return [(name, ref)]-primitiveDataPatternMatch (PDInductivePat name patterns) ref = do-  whnf <- lift $ evalRef ref+primitiveDataPatternMatch (PDPatVar name) whnf = do+  ref <- lift $ newEvaluatedObjectRef whnf+  return [(name, ref)]+primitiveDataPatternMatch (PDInductivePat name patterns) whnf = do   case whnf of-    Intermediate (IInductiveData name' refs) | name == name' ->-      concat <$> zipWithM primitiveDataPatternMatch patterns refs+    Intermediate (IInductiveData name' refs) | name == name' -> do+      whnfs <- lift $ mapM evalRef refs+      concat <$> zipWithM primitiveDataPatternMatch patterns whnfs     Value (InductiveData name' vals) | name == name' -> do-      refs <- lift $ mapM (newEvalutedObjectRef . Value) vals-      concat <$> zipWithM primitiveDataPatternMatch patterns refs+      let whnfs = map Value vals+      concat <$> zipWithM primitiveDataPatternMatch patterns whnfs     _ -> matchFail-primitiveDataPatternMatch (PDTuplePat patterns) ref = do-  whnf <- lift $ evalRef ref+primitiveDataPatternMatch (PDTuplePat patterns) whnf = do   case whnf of-    Intermediate (ITuple refs) ->-      concat <$> zipWithM primitiveDataPatternMatch patterns refs+    Intermediate (ITuple refs) -> do+      whnfs <- lift $ mapM evalRef refs+      concat <$> zipWithM primitiveDataPatternMatch patterns whnfs     Value (Tuple vals) -> do-      refs <- lift $ mapM (newEvalutedObjectRef . Value) vals-      concat <$> zipWithM primitiveDataPatternMatch patterns refs+      let whnfs = map Value vals+      concat <$> zipWithM primitiveDataPatternMatch patterns whnfs     _ -> matchFail-primitiveDataPatternMatch PDEmptyPat ref = do-  whnf <- lift $ evalRef ref+primitiveDataPatternMatch PDEmptyPat whnf = do   isEmpty <- lift $ isEmptyCollection whnf   if isEmpty then return [] else matchFail-primitiveDataPatternMatch (PDConsPat pattern pattern') ref = do-  whnf <- lift $ evalRef ref+primitiveDataPatternMatch (PDConsPat pattern pattern') whnf = do   (head, tail) <- unconsCollection whnf-  (++) <$> primitiveDataPatternMatch pattern head-       <*> primitiveDataPatternMatch pattern' tail-primitiveDataPatternMatch (PDSnocPat pattern pattern') ref = do-  whnf <- lift $ evalRef ref+  head' <- lift $ evalRef head+  tail' <- lift $ evalRef tail+  (++) <$> primitiveDataPatternMatch pattern head'+       <*> primitiveDataPatternMatch pattern' tail'+primitiveDataPatternMatch (PDSnocPat pattern pattern') whnf = do   (init, last) <- unsnocCollection whnf-  (++) <$> primitiveDataPatternMatch pattern init-       <*> primitiveDataPatternMatch pattern' last-primitiveDataPatternMatch (PDConstantPat expr) ref = do-  target <- lift (evalRef ref) >>= either (const matchFail) return . extractPrimitiveValue+  init' <- lift $ evalRef init+  last' <- lift $ evalRef last+  (++) <$> primitiveDataPatternMatch pattern init'+       <*> primitiveDataPatternMatch pattern' last'+primitiveDataPatternMatch (PDConstantPat expr) whnf = do+  target <- (either (const matchFail) return . extractPrimitiveValue) whnf   isEqual <- lift $ (==) <$> evalExprDeep nullEnv expr <*> pure target   if isEqual then return [] else matchFail  expandCollection :: WHNFData -> EgisonM (Seq Inner) expandCollection (Value (Collection vals)) =-  mapM (liftM IElement . newEvalutedObjectRef . Value) vals+  mapM (liftM IElement . newEvaluatedObjectRef . Value) vals expandCollection (Intermediate (ICollection innersRef)) = liftIO $ readIORef innersRef expandCollection val = throwError $ TypeMismatch "collection" val @@ -1005,15 +1199,15 @@   case Sq.viewl col of     EmptyL -> matchFail     val :< vals ->-      lift $ (,) <$> newEvalutedObjectRef (Value val)-                 <*> newEvalutedObjectRef (Value $ Collection vals)+      lift $ (,) <$> newEvaluatedObjectRef (Value val)+                 <*> newEvaluatedObjectRef (Value $ Collection vals) unconsCollection coll@(Intermediate (ICollection innersRef)) = do   inners <- liftIO $ readIORef innersRef   case Sq.viewl inners of     EmptyL -> matchFail     (IElement ref') :< tInners -> do       tInnersRef <- liftIO $ newIORef tInners-      lift $ (ref', ) <$> newEvalutedObjectRef (Intermediate $ ICollection tInnersRef)+      lift $ (ref', ) <$> newEvaluatedObjectRef (Intermediate $ ICollection tInnersRef)     (ISubCollection ref') :< tInners -> do       hInners <- lift $ evalRef ref' >>= expandCollection       liftIO $ writeIORef innersRef (hInners >< tInners)@@ -1025,15 +1219,15 @@   case Sq.viewr col of     EmptyR -> matchFail     vals :> val ->-      lift $ (,) <$> newEvalutedObjectRef (Value $ Collection vals)-                 <*> newEvalutedObjectRef (Value val)+      lift $ (,) <$> newEvaluatedObjectRef (Value $ Collection vals)+                 <*> newEvaluatedObjectRef (Value val) unsnocCollection coll@(Intermediate (ICollection innersRef)) = do   inners <- liftIO $ readIORef innersRef   case Sq.viewr inners of     EmptyR -> matchFail     hInners :> (IElement ref') -> do       hInnersRef <- liftIO $ newIORef hInners-      lift $ (, ref') <$> newEvalutedObjectRef (Intermediate $ ICollection hInnersRef)+      lift $ (, ref') <$> newEvaluatedObjectRef (Intermediate $ ICollection hInnersRef)     hInners :> (ISubCollection ref') -> do       tInners <- lift $ evalRef ref' >>= expandCollection       liftIO $ writeIORef innersRef (hInners >< tInners)@@ -1062,9 +1256,14 @@  fromTuple :: WHNFData -> EgisonM [ObjectRef] fromTuple (Intermediate (ITuple refs)) = return refs-fromTuple (Value (Tuple vals)) = mapM (newEvalutedObjectRef . Value) vals-fromTuple whnf = return <$> newEvalutedObjectRef whnf+fromTuple (Value (Tuple vals)) = mapM (newEvaluatedObjectRef . Value) vals+fromTuple whnf = return <$> newEvaluatedObjectRef whnf +fromTupleWHNF :: WHNFData -> EgisonM [WHNFData]+fromTupleWHNF (Intermediate (ITuple refs)) = mapM evalRef refs+fromTupleWHNF (Value (Tuple vals)) = return $ map Value vals+fromTupleWHNF whnf = return [whnf]+ fromTupleValue :: EgisonValue -> [EgisonValue] fromTupleValue (Tuple vals) = vals fromTupleValue val = [val]@@ -1072,7 +1271,7 @@ fromCollection :: WHNFData -> EgisonM (MList EgisonM ObjectRef) fromCollection (Value (Collection vals)) =   if Sq.null vals then return MNil-                  else fromSeq <$> mapM (newEvalutedObjectRef . Value) vals+                  else fromSeq <$> mapM (newEvaluatedObjectRef . Value) vals fromCollection whnf@(Intermediate (ICollection _)) = do   isEmpty <- isEmptyCollection whnf   if isEmpty@@ -1094,9 +1293,11 @@ collectionToList :: WHNFData -> EgisonM [EgisonValue] collectionToList whnf = do   val <- evalWHNF whnf-  return $ collectionToList' val+  collectionToList' val  where-  collectionToList' (Collection sq) = toList sq+  collectionToList' :: EgisonValue -> EgisonM [EgisonValue]+  collectionToList' (Collection sq) = return $ toList sq+  collectionToList' val = throwError $ TypeMismatch "collection" (Value val)  makeTuple :: [EgisonValue] -> EgisonValue makeTuple [] = Tuple []

@@ -22,6 +22,7 @@ import qualified Data.Sequence as Sq import Data.Sequence (ViewL(..), (<|)) import qualified Data.Set as S+import Data.List (span) import Data.Set (Set) import Data.Char (toUpper) import Control.Monad.Error@@ -40,6 +41,9 @@ desugarTopExpr (Define name expr) = do   expr' <- liftEgisonM $ runDesugarM $ desugar expr   return (Define name expr')+desugarTopExpr (Redefine name expr) = do+  expr' <- liftEgisonM $ runDesugarM $ desugar expr+  return (Redefine name expr') desugarTopExpr (Test expr) = do   expr' <- liftEgisonM $ runDesugarM $ desugar expr   return (Test expr')@@ -122,23 +126,19 @@  desugar (MatchAllLambdaExpr matcher clause) = do   name <- fresh-  matcher' <- desugar matcher-  clause' <- desugarMatchClause clause-  return $ LambdaExpr [name] (MatchAllExpr (VarExpr name) matcher' clause')+  desugar $ LambdaExpr [TensorArg name] (MatchAllExpr (VarExpr name) matcher clause)  desugar (MatchLambdaExpr matcher clauses) = do   name <- fresh-  matcher' <- desugar matcher-  clauses' <- desugarMatchClauses clauses-  return $ LambdaExpr [name] (MatchExpr (VarExpr name) matcher' clauses')+  desugar $ LambdaExpr [TensorArg name] (MatchExpr (VarExpr name) matcher clauses)  desugar (ArrayRefExpr expr nums) =   case nums of-    (TupleExpr nums') -> desugar $ IndexedExpr expr nums'-    _ -> desugar $ IndexedExpr expr [nums]+    (TupleExpr nums') -> desugar $ IndexedExpr expr (map Subscript nums')+    _ -> desugar $ IndexedExpr expr [Subscript nums]    desugar (IndexedExpr expr indices) = -  IndexedExpr <$> desugar expr <*> (mapM desugar indices)+  IndexedExpr <$> desugar expr <*> (mapM desugarIndex indices)  desugar (PowerExpr expr1 expr2) = do   expr1' <- desugar expr1@@ -169,9 +169,32 @@       (CollectionExpr inners') <- desugar (CollectionExpr inners)       return $ CollectionExpr (SubCollectionExpr sub':inners') +desugar (VectorExpr exprs) = do+  exprs' <- mapM desugar exprs+  return $ VectorExpr exprs'++desugar (TensorExpr nsExpr xsExpr supExpr subExpr) = do+  nsExpr' <- desugar nsExpr+  xsExpr' <- desugar xsExpr+  return $ TensorExpr nsExpr' xsExpr' supExpr subExpr+ desugar (LambdaExpr names expr) = do-  expr' <- desugar expr-  return $ LambdaExpr names expr'+  let (rtnames, rhnames) = span (\name -> case name of+                                            TensorArg _ -> True+                                            ScalarArg _ -> False) (reverse names)+  case rhnames of+    [] -> do expr' <- desugar expr+             return $ LambdaExpr names expr'+    (ScalarArg rhname:rhnames') -> do+      let (rtnames2, rhnames2) = span (\name -> case name of+                                                TensorArg _ -> True+                                                ScalarArg _ -> False) rhnames'+      case rhnames2 of+        [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames)+                          (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (VarExpr rhname))+        (ScalarArg rhname2:rhnames2') ->+          desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames)+                      (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (VarExpr rhname2) (VarExpr rhname))  desugar (MemoizedLambdaExpr names expr) = do   expr' <- desugar expr@@ -190,6 +213,10 @@   expr' <- desugar expr   return $ CambdaExpr name expr' +desugar (ProcedureExpr names expr) = do+  expr' <- desugar expr+  return $ ProcedureExpr names expr'+ --desugar (MacroExpr names expr) = do --  expr' <- desugar expr --  return $ MacroExpr names expr'@@ -219,6 +246,10 @@   expr' <- desugar expr   return $ foldr (\bind ret -> LetExpr [bind] ret) expr' binds' +desugar (WithSymbolsExpr vars expr) = do+  expr' <- desugar expr+  return $ WithSymbolsExpr vars expr'+ desugar (MatchExpr expr0 expr1 clauses) = do     expr0' <- desugar expr0   expr1' <- desugar expr1@@ -256,6 +287,11 @@   sizeExpr' <- desugar sizeExpr   return $ GenerateTensorExpr fnExpr' sizeExpr' +desugar (TensorContractExpr fnExpr tExpr) = do+  fnExpr' <- desugar fnExpr+  tExpr' <- desugar tExpr+  return $ TensorContractExpr fnExpr' tExpr'+ desugar (TensorMapExpr fnExpr tExpr) = do   fnExpr' <- desugar fnExpr   tExpr' <- desugar tExpr@@ -280,6 +316,10 @@ desugar (VarExpr name) = do   asks $ maybe (VarExpr name) id . lookup name +desugar FreshVarExpr = do+  id <- fresh+  return (VarExpr (":::" ++ id))+ desugar (MatcherBFSExpr matcherInfo) = do   matcherInfo' <- desugarMatcherInfo matcherInfo   return $ MatcherBFSExpr matcherInfo'@@ -288,20 +328,27 @@   matcherInfo' <- desugarMatcherInfo matcherInfo   return $ MatcherDFSExpr matcherInfo'   -desugar (PartialVarExpr n) = return $ VarExpr $ "::" ++ show n--desugar RecVarExpr = return $ VarExpr "::"+desugar (PartialVarExpr n) = return $ PartialVarExpr n  desugar (PartialExpr n expr) = do   expr' <- desugar expr-  if n == 0-    then return $ LetRecExpr [(["::"], LambdaExpr [] expr')] (LambdaExpr [] expr')-    else return $ LetRecExpr [(["::"], LambdaExpr (annonVars (fromIntegral n)) expr')] (LambdaExpr (annonVars (fromIntegral n)) expr')- where-  annonVars n = take n $ map (((++) "::") . show) [1..]+  return $ LetRecExpr [(["::0"], PartialExpr n expr')] (VarExpr "::0") +desugar (QuoteExpr expr) = do+  expr' <- desugar expr+  return $ QuoteExpr expr'++desugar (QuoteFunctionExpr expr) = do+  expr' <- desugar expr+  return $ QuoteFunctionExpr expr'+ desugar expr = return expr +desugarIndex :: Index EgisonExpr -> DesugarM (Index EgisonExpr)+desugarIndex (Superscript expr) = desugar expr >>= return . Superscript+desugarIndex (Subscript expr) = desugar expr >>= return . Subscript+desugarIndex (SupSubscript expr) = desugar expr >>= return . SupSubscript+ desugarPattern :: EgisonPattern -> DesugarM EgisonPattern desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern   where@@ -320,6 +367,10 @@    collectName (LetPat _ pattern) = collectName pattern    collectName (IndexedPat (PatVar name) _) = S.singleton name    collectName (OrPat patterns) = collectNames patterns+   collectName (DivPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2+   collectName (PlusPat patterns) = collectNames patterns+   collectName (MultPat patterns) = collectNames patterns+   collectName (PowerPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2    collectName _ = S.empty        makeBinding :: String -> BindingExpr@@ -343,6 +394,31 @@ desugarPattern' (DApplyPat pattern patterns) = DApplyPat <$> desugarPattern' pattern <*> mapM desugarPattern' patterns  desugarPattern' (LoopPat name range pattern1 pattern2) =  LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' (LetPat binds pattern) = LetPat <$> desugarBindings binds <*> desugarPattern' pattern+desugarPattern' (DivPat pattern1 pattern2) = do+  pat1' <- desugarPattern' pattern1+  pat2' <- desugarPattern' pattern2+  return $ InductivePat "div" [pat1', pat2']+desugarPattern' (PlusPat patterns) = do+  pats' <- mapM desugarPattern' patterns+  case (reverse pats') of+    [] -> return $ InductivePat "plus" [ValuePat (IntegerExpr 0)]+    lp:hps ->+      return $ InductivePat "plus" [foldr (\p r -> InductivePat "cons" [p, r]) lp (reverse hps)]+desugarPattern' (MultPat (intPat:patterns)) = do+  intPat' <- desugarPattern' intPat+  pats' <- mapM desugarPattern' patterns+  case (reverse pats') of+    [] -> return $ InductivePat "mult" [intPat', ValuePat (IntegerExpr 1)]+    lp:hps ->+      return $ InductivePat "mult" [intPat',+                                    foldr (\p r -> case p of+                                                     (PowerPat p1 p2) -> InductivePat "ncons" [p1, p2, r]+                                                     _ -> InductivePat "cons" [p, r])+                                          (case lp of+                                             (PowerPat p1 p2) -> InductivePat "ncons" [p1, p2, ValuePat (IntegerExpr 1)]+                                             _ -> lp)+                                          (reverse hps)]+desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' pattern = return pattern  desugarLoopRange :: LoopRange -> DesugarM LoopRange

@@ -126,6 +126,7 @@ topExpr :: Parser EgisonTopExpr topExpr = try (Test <$> expr)       <|> try (parens (defineExpr+                   <|> redefineExpr                    <|> testExpr                    <|> executeExpr                    <|> loadFileExpr@@ -133,8 +134,11 @@       <?> "top-level expression"  defineExpr :: Parser EgisonTopExpr-defineExpr = keywordDefine >> Define <$> varName <*> expr+defineExpr = keywordDefine >> Define <$> varNameWithIndexType <*> expr +redefineExpr :: Parser EgisonTopExpr+redefineExpr = (keywordRedefine <|> keywordSet) >> Redefine <$> varNameWithIndexType <*> expr+ testExpr :: Parser EgisonTopExpr testExpr = keywordTest >> Test <$> expr @@ -152,31 +156,36 @@  expr :: Parser EgisonExpr expr = P.lexeme lexer (do expr0 <- expr'-                          expr1 <- option expr0 $ PowerExpr expr0 <$> (try $ char '^' >> expr')-                          option expr1 $ IndexedExpr expr1 <$> many1 (try $ char '_' >> expr'))+                          expr1 <- option expr0 $ IndexedExpr expr0 <$> many1 (try (char '_' >> expr' >>= return . Subscript) <|> try (char '~' >> expr' >>= return . Superscript) <|> try (string "~_" >> expr' >>= return . SupSubscript))+                          option expr1 $ PowerExpr expr1 <$> (try $ char '^' >> expr'))+                            expr' :: Parser EgisonExpr expr' = (try partialExpr              <|> try constantExpr              <|> try partialVarExpr-             <|> recVarExpr+             <|> try freshVarExpr              <|> try varExpr              <|> inductiveDataExpr              <|> try arrayExpr-             <|> try tensorExpr+             <|> try vectorExpr              <|> try tupleExpr              <|> try hashExpr              <|> collectionExpr+             <|> quoteExpr+             <|> quoteFunctionExpr              <|> parens (ifExpr                          <|> lambdaExpr                          <|> memoizedLambdaExpr                          <|> memoizeExpr                          <|> cambdaExpr+                         <|> procedureExpr                          <|> macroExpr                          <|> patternFunctionExpr                          <|> letRecExpr                          <|> letExpr                          <|> letStarExpr+                         <|> withSymbolsExpr                          <|> doExpr                          <|> ioExpr                          <|> matchAllExpr@@ -198,7 +207,8 @@                          <|> arrayBoundsExpr                          <|> arrayRefExpr                          <|> generateTensorExpr-                         <|> initTensorExpr+                         <|> tensorExpr+                         <|> tensorContractExpr                          <|> tensorMapExpr                          <|> tensorMap2Expr                          )@@ -207,6 +217,9 @@ varExpr :: Parser EgisonExpr varExpr = VarExpr <$> ident +freshVarExpr :: Parser EgisonExpr+freshVarExpr = char '#' >> return FreshVarExpr+ inductiveDataExpr :: Parser EgisonExpr inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy expr whiteSpace @@ -223,15 +236,15 @@ arrayExpr :: Parser EgisonExpr arrayExpr = between lp rp $ ArrayExpr <$> sepEndBy expr whiteSpace   where-    lp = P.lexeme lexer (string "[|")-    rp = string "|]"--tensorExpr :: Parser EgisonExpr-tensorExpr = between lp rp $ TensorExpr <$> expr <*> expr-  where     lp = P.lexeme lexer (string "(|")     rp = string "|)" +vectorExpr :: Parser EgisonExpr+vectorExpr = between lp rp $ VectorExpr <$> sepEndBy expr whiteSpace+  where+    lp = P.lexeme lexer (string "[|")+    rp = string "|]"+ hashExpr :: Parser EgisonExpr hashExpr = between lp rp $ HashExpr <$> sepEndBy pairExpr whiteSpace   where@@ -240,6 +253,12 @@     pairExpr :: Parser (EgisonExpr, EgisonExpr)     pairExpr = brackets $ (,) <$> expr <*> expr +quoteExpr :: Parser EgisonExpr+quoteExpr = char '\'' >> QuoteExpr <$> expr++quoteFunctionExpr :: Parser EgisonExpr+quoteFunctionExpr = char '`' >> QuoteFunctionExpr <$> expr+ matchAllExpr :: Parser EgisonExpr matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> matchClause @@ -305,7 +324,7 @@ ppPatVar = reservedOp "$" *> pure PPPatVar  ppValuePat :: Parser PrimitivePatPattern-ppValuePat = string ",$" >> PPValuePat <$> ident+ppValuePat = reservedOp ",$" >> PPValuePat <$> ident  ppInductivePat :: Parser PrimitivePatPattern ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace)@@ -328,7 +347,7 @@ ifExpr = keywordIf >> IfExpr <$> expr <*> expr <*> expr  lambdaExpr :: Parser EgisonExpr-lambdaExpr = keywordLambda >> LambdaExpr <$> varNames <*> expr+lambdaExpr = keywordLambda >> LambdaExpr <$> argNames <*> expr  memoizedLambdaExpr :: Parser EgisonExpr memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <*> expr@@ -345,6 +364,9 @@ cambdaExpr :: Parser EgisonExpr cambdaExpr = keywordCambda >> CambdaExpr <$> varName <*> expr +procedureExpr :: Parser EgisonExpr+procedureExpr = keywordProcedure >> ProcedureExpr <$> varNames <*> expr+ macroExpr :: Parser EgisonExpr macroExpr = keywordMacro >> MacroExpr <$> varNames <*> expr @@ -360,6 +382,9 @@ letStarExpr :: Parser EgisonExpr letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <*> expr +withSymbolsExpr :: Parser EgisonExpr+withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> (braces $ sepEndBy ident whiteSpace) <*> expr+ doExpr :: Parser EgisonExpr doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr "return") (TupleExpr [])) expr @@ -384,15 +409,31 @@ varName :: Parser String varName = char '$' >> ident +varNameWithIndexType :: Parser Var+varNameWithIndexType = P.lexeme lexer (do+  char '$'+  name <- ident+  is <- many indexType+  return $ Var name is)++indexType :: Parser (Index ())+indexType = try (char '~' >> return (Superscript ()))+        <|> try (char '_' >> return (Subscript ()))++argNames :: Parser [Arg]+argNames = return <$> argName+            <|> brackets (sepEndBy argName whiteSpace) ++argName :: Parser Arg+argName = try (char '$' >> ident >>= return . ScalarArg)+      <|> try (char '%' >> ident >>= return . TensorArg)+ ioExpr :: Parser EgisonExpr ioExpr = keywordIo >> IoExpr <$> expr  seqExpr :: Parser EgisonExpr seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr -recVarExpr :: Parser EgisonExpr-recVarExpr = reservedOp "#" >> pure RecVarExpr- cApplyExpr :: Parser EgisonExpr cApplyExpr = (keywordCApply >> CApplyExpr <$> expr <*> expr)  @@ -410,14 +451,14 @@     _ | all null vars ->         let genVar = modify (1+) >> gets (VarExpr . (':':) . show)             args' = evalState (mapM (either (const genVar) return) args) 0-        in return . LambdaExpr (annonVars $ length vars) . ApplyExpr func $ TupleExpr args'+        in return . LambdaExpr (map ScalarArg (annonVars $ length vars)) . ApplyExpr func $ TupleExpr args'       | all (not . null) vars ->         let ns = Set.fromList $ map read vars             n = Set.size ns         in if Set.findMin ns == 1 && Set.findMax ns == n              then                let args' = map (either (VarExpr . (':':)) id) args-               in return . LambdaExpr (annonVars n) . ApplyExpr func $ TupleExpr args'+               in return . LambdaExpr (map ScalarArg (annonVars n)) . ApplyExpr func $ TupleExpr args'              else fail "invalid partial application"       | otherwise -> fail "invalid partial application"  where@@ -439,7 +480,7 @@ algebraicDataMatcherExpr = keywordAlgebraicDataMatcher                                 >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 inductivePat' whiteSpace)   where-    inductivePat' :: Parser (String, [EgisonExpr]) +    inductivePat' :: Parser (String, [EgisonExpr])     inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace  generateArrayExpr :: Parser EgisonExpr@@ -459,9 +500,12 @@ generateTensorExpr :: Parser EgisonExpr generateTensorExpr = keywordGenerateTensor >> GenerateTensorExpr <$> expr <*> expr -initTensorExpr :: Parser EgisonExpr-initTensorExpr = keywordInitTensor >> InitTensorExpr <$> expr <*> expr <*> expr+tensorExpr :: Parser EgisonExpr+tensorExpr = keywordTensor >> TensorExpr <$> expr <*> expr <*> option (CollectionExpr []) expr <*> option (CollectionExpr []) expr +tensorContractExpr :: Parser EgisonExpr+tensorContractExpr = keywordTensorContract >> TensorContractExpr <$> expr <*> expr+ tensorMapExpr :: Parser EgisonExpr tensorMapExpr = keywordTensorMap >> TensorMapExpr <$> expr <*> expr @@ -480,7 +524,6 @@             <|> patVar             <|> varPat             <|> valuePat-            <|> regexPat             <|> predPat             <|> notPat             <|> tuplePat@@ -490,8 +533,12 @@                     <|> orPat                     <|> loopPat                     <|> letPat+                    <|> try divPat+                    <|> try plusPat+                    <|> try multPat                     <|> try dApplyPat                     <|> try pApplyPat+--                    <|> powerPat                     )  pattern'' :: Parser EgisonPattern@@ -511,17 +558,14 @@ valuePat :: Parser EgisonPattern valuePat = char ',' >> ValuePat <$> expr -regexPat :: Parser EgisonPattern-regexPat = reservedOp "~" >> RegexPat <$> expr- predPat :: Parser EgisonPattern-predPat = reservedOp "?" >> PredPat <$> expr+predPat = char '?' >> PredPat <$> expr  letPat :: Parser EgisonPattern letPat = keywordLet >> LetPat <$> bindings <*> pattern  notPat :: Parser EgisonPattern-notPat = reservedOp "!" >> NotPat <$> pattern+notPat = char '!' >> NotPat <$> pattern  tuplePat :: Parser EgisonPattern tuplePat = brackets $ TuplePat <$> sepEndBy pattern whiteSpace@@ -557,14 +601,30 @@                               return (LoopRange s e ep))                  <|> (do s <- expr                          ep <- option WildCard pattern-                         return (LoopRange s (ApplyExpr (VarExpr "from") (ApplyExpr (VarExpr "-") (TupleExpr [s, (IntegerExpr 1)]))) ep)))+                         return (LoopRange s (ApplyExpr (VarExpr "from") (ApplyExpr (VarExpr "-'") (TupleExpr [s, (IntegerExpr 1)]))) ep))) +divPat :: Parser EgisonPattern+divPat = reservedOp "/" >> DivPat <$> pattern <*> pattern++plusPat :: Parser EgisonPattern+plusPat = reservedOp "+" >> PlusPat <$> sepEndBy pattern whiteSpace++multPat :: Parser EgisonPattern+multPat = reservedOp "*" >> MultPat <$> sepEndBy powerPat whiteSpace++powerPat :: Parser EgisonPattern+powerPat = try (do pat1 <- pattern+                   char '^'+                   pat2 <- pattern+                   return $ PowerPat pat1 pat2)+       <|> pattern+ -- Constants  constantExpr :: Parser EgisonExpr-constantExpr =  charExpr-                 <|> stringExpr+constantExpr = stringExpr                  <|> boolExpr+                 <|> try charExpr                  <|> try floatExpr                  <|> try integerExpr                  <|> (keywordSomething *> pure SomethingExpr)@@ -625,7 +685,7 @@   P.LanguageDef { P.commentStart       = "#|"                 , P.commentEnd         = "|#"                 , P.commentLine        = ";"-                , P.identStart         = letter <|> symbol1+                , P.identStart         = letter <|> symbol1 <|> symbol0                 , P.identLetter        = letter <|> digit <|> symbol2                 , P.opStart            = symbol1                 , P.opLetter           = symbol1@@ -634,7 +694,8 @@                 , P.nestedComments     = True                 , P.caseSensitive      = True } -symbol1 = oneOf "+-*/=."+symbol0 = oneOf "^"+symbol1 = oneOf "+-*/=.∂∇" symbol2 = symbol1 <|> oneOf "'!?"  lexer :: P.GenTokenParser String () Identity@@ -643,6 +704,8 @@ reservedKeywords :: [String] reservedKeywords =    [ "define"+  , "redefine"+  , "set!"   , "test"   , "execute"   , "load-file"@@ -655,11 +718,13 @@   , "memoized-lambda"   , "memoize"   , "cambda"+  , "procedure"   , "macro"   , "pattern-function"   , "letrec"   , "let"   , "let*"+  , "with-symbols"   , "loop"   , "match-all"   , "match"@@ -675,7 +740,8 @@   , "array-bounds"   , "array-ref"   , "generate-tensor"-  , "init-tensor"+  , "tensor"+  , "contract"   , "tensor-map"   , "tensor-map2"   , "something"@@ -684,15 +750,17 @@ reservedOperators :: [String] reservedOperators =    [ "$"+  , ",$"   , "_"   , "^"   , "&"   , "|"   , "|*"-  , "!"-  , ","-  , "~"-  , "@"+--  , "'"+--  , "~"+--  , "!"+--  , ","+--  , "@"   , "..."]  reserved :: String -> Parser ()@@ -702,6 +770,8 @@ reservedOp = P.reservedOp lexer  keywordDefine               = reserved "define"+keywordRedefine             = reserved "redefine"+keywordSet                  = reserved "set!" keywordTest                 = reserved "test" keywordExecute              = reserved "execute" keywordLoadFile             = reserved "load-file"@@ -716,11 +786,13 @@ keywordMemoizedLambda       = reserved "memoized-lambda" keywordMemoize              = reserved "memoize" keywordCambda               = reserved "cambda"+keywordProcedure            = reserved "procedure" keywordMacro                = reserved "macro" keywordPatternFunction      = reserved "pattern-function" keywordLetRec               = reserved "letrec" keywordLet                  = reserved "let" keywordLetStar              = reserved "let*"+keywordWithSymbols          = reserved "with-symbols" keywordLoop                 = reserved "loop" keywordCont                 = reserved "..." keywordMatchAll             = reserved "match-all"@@ -743,7 +815,8 @@ keywordArrayBounds          = reserved "array-bounds" keywordArrayRef             = reserved "array-ref" keywordGenerateTensor       = reserved "generate-tensor"-keywordInitTensor           = reserved "init-tensor"+keywordTensor               = reserved "tensor"+keywordTensorContract       = reserved "contract" keywordTensorMap            = reserved "tensor-map" keywordTensorMap2           = reserved "tensor-map2" @@ -768,8 +841,10 @@ stringLiteral :: Parser String stringLiteral = P.stringLiteral lexer +--charLiteral :: Parser Char+--charLiteral = P.charLiteral lexer charLiteral :: Parser Char-charLiteral = P.charLiteral lexer+charLiteral = string "c#" >> anyChar  boolLiteral :: Parser Bool boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False)

@@ -25,6 +25,7 @@ import System.Process  import qualified Data.Sequence as Sq+import qualified Data.Vector as V  import Data.Char (ord, chr) import qualified Data.Text as T@@ -65,23 +66,50 @@  {-# INLINE oneArg #-} oneArg :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc-oneArg f = \args -> do-  args' <- evalWHNF args-  f args' >>= return . Value+oneArg f = \arg -> do+  arg' <- evalWHNF arg+  case arg' of+    (TensorData (Tensor ns ds js)) -> do+      ds' <- mapM (\d -> f d) ds+      fromTensor (Tensor ns ds' js) >>= return . Value +    _ -> f arg' >>= return . Value +{-# INLINE oneArg' #-}+oneArg' :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc+oneArg' f = \arg -> do+  arg' <- evalWHNF arg+  case arg' of+    _ -> f arg' >>= return . Value+ {-# INLINE twoArgs #-} twoArgs :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc twoArgs f = \args -> do   args' <- tupleToList args   case args' of +    [(TensorData t1@(Tensor _ _ _)), (TensorData t2@(Tensor _ _ _))] -> do+      tProduct f t1 t2 >>= fromTensor >>= return . Value+    [(TensorData(Tensor ns ds js)), val] -> do+      ds' <- mapM (\d -> f d val) ds+      fromTensor (Tensor ns ds' js) >>= return . Value +    [val, (TensorData (Tensor ns ds js))] -> do+      ds' <- mapM (\d -> f val d) ds+      fromTensor (Tensor ns ds' js) >>= return . Value      [val, val'] -> f val val' >>= return . Value     _ -> throwError $ ArgumentsNumPrimitive 2 $ length args' -{-# INLINE threeArgs #-}-threeArgs :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc-threeArgs f = \args -> do+{-# INLINE twoArgs' #-}+twoArgs' :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc+twoArgs' f = \args -> do   args' <- tupleToList args   case args' of +    [val, val'] -> f val val' >>= return . Value+    _ -> throwError $ ArgumentsNumPrimitive 2 $ length args'++{-# INLINE threeArgs' #-}+threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc+threeArgs' f = \args -> do+  args' <- tupleToList args+  case args' of      [val, val', val''] -> f val val' val'' >>= return . Value     _ -> throwError $ ArgumentsNumPrimitive 3 $ length args' @@ -108,6 +136,10 @@              , ("b.-'", minus)              , ("b.*'", multiply)              , ("b./'", divide)+             , ("f.+", floatPlus)+             , ("f.-", floatMinus)+             , ("f.*", floatMult)+             , ("f./", floatDivide)              , ("numerator", numerator')              , ("denominator", denominator')              , ("from-math-expr", fromScalarData)@@ -150,11 +182,8 @@              , ("b.acosh", floatUnaryOp acosh)              , ("b.atanh", floatUnaryOp atanh) -             , ("b..", tensorProd)-             , ("b..'", tensorProd)-             , ("tensor-index", tensorIndex)-             , ("tensor-size", tensorSize)-             , ("tensor-to-list", tensorToList)+             , ("tensor-size", tensorSize')+             , ("tensor-to-list", tensorToList')               , ("itof", integerToFloat)              , ("rtof", rationalToFloat)@@ -170,6 +199,10 @@              , ("regex", regexString)              , ("regex-cg", regexStringCaptureGroup) +             , ("add-prime", addPrime)+             , ("add-subscript", addSubscript)+             , ("add-superscript", addSuperscript)+              , ("read-process", readProcess')                              , ("read", read')@@ -184,7 +217,7 @@              , ("bool?", isBool')              , ("integer?", isInteger')              , ("rational?", isRational')-             , ("number?", isNumber')+             , ("scalar?", isScalar')              , ("float?", isFloat')              , ("char?", isChar')              , ("string?", isString')@@ -247,46 +280,53 @@   f' <- fromEgison val'   return $ Bool $ pred f f' +floatPlus :: PrimitiveFunc+floatPlus = twoArgs $ \val val' -> do+  case (val, val') of+    ((Float x y), (Float x' y')) -> return $ Float (x + x')  (y + y')+    _ -> throwError $ TypeMismatch "float" (Value val)++floatMinus :: PrimitiveFunc+floatMinus = twoArgs $ \val val' -> do+  case (val, val') of+    ((Float x y), (Float x' y')) -> return $ Float (x - x')  (y - y')+    _ -> throwError $ TypeMismatch "float" (Value val)++floatMult :: PrimitiveFunc+floatMult = twoArgs $ \val val' -> do+  case (val, val') of+    ((Float x y), (Float x' y')) -> return $ Float (x * x' - y * y')  (x * y' + x' * y)+    _ -> throwError $ TypeMismatch "float" (Value val)++floatDivide :: PrimitiveFunc+floatDivide = twoArgs $ \val val' -> do+  case (val, val') of+    ((Float x y), (Float x' y')) -> return $ Float ((x * x' + y * y') / (x' * x' + y' * y')) ((y * x' - x * y') / (x' * x' + y' * y'))+    _ -> throwError $ TypeMismatch "float" (Value val)++ -- -- Arith -- -numberUnaryOp :: (ScalarData -> ScalarData) -> (EgisonValue -> EgisonValue) -> PrimitiveFunc-numberUnaryOp mOp fOp arg = do-  arg' <- tupleToList arg-  case arg' of -    [val] -> numberUnaryOp' val >>= return . Value-    _ -> throwError $ ArgumentsNumPrimitive 1 $ length arg'- where-  numberUnaryOp' f@(Float _ _)  = return $ fOp f-  numberUnaryOp' (ScalarData m) = (return . ScalarData . mathNormalize') (mOp m)-  numberUnaryOp' val            = throwError $ TypeMismatch "number" (Value val)--numberBinaryOp :: (ScalarData -> ScalarData -> ScalarData) -> (EgisonValue -> EgisonValue -> EgisonValue) -> PrimitiveFunc-numberBinaryOp mOp fOp args = do-  args' <- tupleToList args-  case args' of -    [val, val'] -> numberBinaryOp' val val' >>= return . Value-    _ -> throwError $ ArgumentsNumPrimitive 2 $ length args'+scalarBinaryOp :: (ScalarData -> ScalarData -> ScalarData) -> PrimitiveFunc+scalarBinaryOp mOp = twoArgs $ \val val' -> do+  scalarBinaryOp' val val'  where-  numberBinaryOp' f@(Float _ _)   f'@(Float _ _)  = return $ fOp f f'-  numberBinaryOp' val             (Float x' y')   = numberBinaryOp' (numberToFloat' val) (Float x' y')-  numberBinaryOp' (Float x y)     val'            = numberBinaryOp' (Float x y) (numberToFloat' val')-  numberBinaryOp' (ScalarData m1) (ScalarData m2) = (return . ScalarData . mathNormalize') (mOp m1 m2)-  numberBinaryOp' (ScalarData _)  val'            = throwError $ TypeMismatch "number" (Value val')-  numberBinaryOp' val             _               = throwError $ TypeMismatch "number" (Value val)+  scalarBinaryOp' (ScalarData m1) (ScalarData m2) = (return . ScalarData . mathNormalize') (mOp m1 m2)+  scalarBinaryOp' val             _               = throwError $ TypeMismatch "number" (Value val)  plus :: PrimitiveFunc-plus = numberBinaryOp mathPlus (\(Float x y) (Float x' y') -> Float (x + x')  (y + y'))+plus = scalarBinaryOp mathPlus  minus :: PrimitiveFunc-minus = numberBinaryOp (\m1 m2 -> mathPlus m1 (mathNegate m2)) (\(Float x y) (Float x' y') -> Float (x - x')  (y - y'))+minus = scalarBinaryOp (\m1 m2 -> mathPlus m1 (mathNegate m2))  multiply :: PrimitiveFunc-multiply = numberBinaryOp mathMult (\(Float x y) (Float x' y') -> Float (x * x' - y * y')  (x * y' + x' * y))+multiply = scalarBinaryOp mathMult  divide :: PrimitiveFunc-divide = numberBinaryOp (\m1 (Div p1 p2) -> mathMult m1 (Div p2 p1)) (\(Float x y) (Float x' y') -> Float ((x * x' + y * y') / (x' * x' + y' * y')) ((y * x' - x * y') / (x' * x' + y' * y')))+divide = scalarBinaryOp (\m1 (Div p1 p2) -> mathMult m1 (Div p2 p1))  numerator' :: PrimitiveFunc numerator' =  oneArg $ numerator''@@ -319,52 +359,52 @@   return $ Bool $ val == val'  lt :: PrimitiveFunc-lt = twoArgs $ \val val' -> numberBinaryPred' val val'+lt = twoArgs $ \val val' -> scalarBinaryPred' val val'  where-  numberBinaryPred' m@(ScalarData _) n@(ScalarData _) = do+  scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do     r <- fromEgison m :: EgisonM Rational     r' <- fromEgison n :: EgisonM Rational     return $ Bool $ (<) r r'-  numberBinaryPred' (Float f 0)  (Float f' 0)  = return $ Bool $ (<) f f'-  numberBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)-  numberBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)-  numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)+  scalarBinaryPred' (Float f 0)  (Float f' 0)  = return $ Bool $ (<) f f'+  scalarBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)+  scalarBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)+  scalarBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)    lte :: PrimitiveFunc-lte = twoArgs $ \val val' -> numberBinaryPred' val val'+lte = twoArgs $ \val val' -> scalarBinaryPred' val val'  where-  numberBinaryPred' m@(ScalarData _) n@(ScalarData _) = do+  scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do     r <- fromEgison m :: EgisonM Rational     r' <- fromEgison n :: EgisonM Rational     return $ Bool $ (<=) r r'-  numberBinaryPred' (Float f 0)  (Float f' 0)  = return $ Bool $ (<=) f f'-  numberBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)-  numberBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)-  numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)+  scalarBinaryPred' (Float f 0)  (Float f' 0)  = return $ Bool $ (<=) f f'+  scalarBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)+  scalarBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)+  scalarBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)    gt :: PrimitiveFunc-gt = twoArgs $ \val val' -> numberBinaryPred' val val'+gt = twoArgs $ \val val' -> scalarBinaryPred' val val'  where-  numberBinaryPred' m@(ScalarData _) n@(ScalarData _) = do+  scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do     r <- fromEgison m :: EgisonM Rational     r' <- fromEgison n :: EgisonM Rational     return $ Bool $ (>) r r'-  numberBinaryPred' (Float f 0)  (Float f' 0)  = return $ Bool $ (>) f f'-  numberBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)-  numberBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)-  numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)+  scalarBinaryPred' (Float f 0)  (Float f' 0)  = return $ Bool $ (>) f f'+  scalarBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)+  scalarBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)+  scalarBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)    gte :: PrimitiveFunc-gte = twoArgs $ \val val' -> numberBinaryPred' val val'+gte = twoArgs $ \val val' -> scalarBinaryPred' val val'  where-  numberBinaryPred' m@(ScalarData _) n@(ScalarData _) = do+  scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do     r <- fromEgison m :: EgisonM Rational     r' <- fromEgison n :: EgisonM Rational     return $ Bool $ (>=) r r'-  numberBinaryPred' (Float f 0)    (Float f' 0)  = return $ Bool $ (>=) f f'-  numberBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)-  numberBinaryPred' (Float _ _)    val           = throwError $ TypeMismatch "float" (Value val)-  numberBinaryPred' val            _             = throwError $ TypeMismatch "number" (Value val)+  scalarBinaryPred' (Float f 0)    (Float f' 0)  = return $ Bool $ (>=) f f'+  scalarBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)+  scalarBinaryPred' (Float _ _)    val           = throwError $ TypeMismatch "float" (Value val)+  scalarBinaryPred' val            _             = throwError $ TypeMismatch "number" (Value val)    truncate' :: PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val@@ -390,35 +430,17 @@ -- Tensor -- -tensorProd :: PrimitiveFunc-tensorProd = twoArgs $ tensorProd'- where-  tensorProd' (TensorData (TData (Tensor ns1 xs1) (Just ms1)))-              (TensorData (TData (Tensor ns2 xs2) (Just ms2))) = do-    ret <- tContract (TData (Tensor (ns1 ++ ns2) (map (\is -> let is1 = take (length ns1) is in-                                                              let is2 = take (length ns2) (drop (length ns1) is) in-                                                                (mathMult (tref' is1 (Tensor ns1 xs1)) (tref' is2 (Tensor ns2 xs2)))-                                                       ) (tensorIndices (ns1 ++ ns2)))) (Just (ms1 ++ ms2)))-    return ret-  tensorProd' val1 val2 = throwError $ TypeMismatch "tensor data with index" (Value (Tuple [val1, val2]))--tensorIndex :: PrimitiveFunc-tensorIndex = oneArg $ tensorIndex'- where-  tensorIndex' (TensorData (TData (Tensor _ _) (Just ms))) = return . Collection . Sq.fromList $ map ScalarData ms-  tensorIndex' val = throwError $ TypeMismatch "tensor with index" (Value val)--tensorSize :: PrimitiveFunc-tensorSize = oneArg $ tensorSize'+tensorSize' :: PrimitiveFunc+tensorSize' = oneArg' $ tensorSize''  where-  tensorSize' (TensorData (TData (Tensor ns _) _)) = return . Collection . Sq.fromList $ map toEgison ns-  tensorSize' val = throwError $ TypeMismatch "tensor data" (Value val)+  tensorSize'' (TensorData (Tensor ns _ _)) = return . Collection . Sq.fromList $ map toEgison ns+  tensorSize'' _ = return . Collection $ Sq.fromList $ [toEgison (1 :: Integer)] -tensorToList :: PrimitiveFunc-tensorToList = oneArg $ tensorToList'+tensorToList' :: PrimitiveFunc+tensorToList' = oneArg' $ tensorToList''  where-  tensorToList' (TensorData (TData (Tensor _ xs) _)) = return . Collection . Sq.fromList $ map ScalarData xs-  tensorToList' val = throwError $ TypeMismatch "tensor data" (Value val)+  tensorToList'' (TensorData (Tensor _ xs _)) = return . Collection . Sq.fromList $ V.toList xs+  tensorToList'' x = return . Collection $ Sq.fromList $ [x]  -- -- Transform@@ -530,8 +552,36 @@ --    (String _, _) -> throwError $ TypeMismatch "string" (Value src) --    (_, _) -> throwError $ TypeMismatch "string" (Value pat) +addPrime :: PrimitiveFunc+addPrime = oneArg $ \sym -> do+  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)++addSubscript :: PrimitiveFunc+addSubscript = twoArgs $ \fn sub -> do+  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)+    _ ->  throwError $ TypeMismatch "symbol or integer" (Value fn)++addSuperscript :: PrimitiveFunc+addSuperscript = twoArgs $ \fn sub -> do+  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)+    _ ->  throwError $ TypeMismatch "symbol" (Value fn)+ readProcess' :: PrimitiveFunc-readProcess' = threeArgs $ \cmd args input -> do+readProcess' = threeArgs' $ \cmd args input -> do   case (cmd, args, input) of     (String cmdStr, Collection argStrs, String inputStr) -> do       outputStr <- liftIO $ readProcess (T.unpack cmdStr) (map (\arg -> case arg of@@ -541,19 +591,19 @@     (_, _, _) -> throwError $ TypeMismatch "(string, collection, string)" (Value (Tuple [cmd, args, input]))  read' :: PrimitiveFunc-read'= oneArg $ \val -> fromEgison val >>= readExpr . T.unpack >>= evalExprDeep nullEnv+read'= oneArg' $ \val -> fromEgison val >>= readExpr . T.unpack >>= evalExprDeep nullEnv  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 rets <- fromEgison val >>= readExprs . T.unpack >>= mapM (evalExprDeep nullEnv)+                              case rets of+                                [ret] -> return ret+                                _ -> return (Tuple rets)  show' :: PrimitiveFunc-show'= oneArg $ \val -> return $ toEgison $ T.pack $ show val+show'= oneArg' $ \val -> return $ toEgison $ T.pack $ show val  showTSV' :: PrimitiveFunc-showTSV'= oneArg $ \val -> return $ toEgison $ T.pack $ showTSV val+showTSV'= oneArg' $ \val -> return $ toEgison $ T.pack $ showTSV val  -- -- Collection@@ -582,14 +632,14 @@ -- Test  assert ::  PrimitiveFunc-assert = twoArgs $ \label test -> do+assert = twoArgs' $ \label test -> do   test <- fromEgison test   if test     then return $ Bool True     else throwError $ Assertion $ show label  assertEqual :: PrimitiveFunc-assertEqual = threeArgs $ \label actual expected -> do+assertEqual = threeArgs' $ \label actual expected -> do   if actual == expected     then return $ Bool True     else throwError $ Assertion $ show label ++ "\n expected: " ++ show expected ++@@ -633,37 +683,37 @@ makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []])  return' :: PrimitiveFunc-return' = oneArg $ \val -> return $ makeIO $ return val+return' = oneArg' $ \val -> return $ makeIO $ return val  makePort :: IOMode -> PrimitiveFunc-makePort mode = oneArg $ \val -> do+makePort mode = oneArg' $ \val -> do   filename <- fromEgison val   port <- liftIO $ openFile (T.unpack filename) mode   return $ makeIO $ return (Port port)  closePort :: PrimitiveFunc-closePort = oneArg $ \val -> do+closePort = oneArg' $ \val -> do   port <- fromEgison val   return $ makeIO' $ liftIO $ hClose port  writeChar :: PrimitiveFunc-writeChar = oneArg $ \val -> do+writeChar = oneArg' $ \val -> do   c <- fromEgison val   return $ makeIO' $ liftIO $ putChar c  writeCharToPort :: PrimitiveFunc-writeCharToPort = twoArgs $ \val val' -> do+writeCharToPort = twoArgs' $ \val val' -> do   port <- fromEgison val   c <- fromEgison val'   return $ makeIO' $ liftIO $ hPutChar port c  writeString :: PrimitiveFunc-writeString = oneArg $ \val -> do+writeString = oneArg' $ \val -> do   s <- fromEgison val   return $ makeIO' $ liftIO $ T.putStr s    writeStringToPort :: PrimitiveFunc-writeStringToPort = twoArgs $ \val val' -> do+writeStringToPort = twoArgs' $ \val val' -> do   port <- fromEgison val   s <- fromEgison val'   return $ makeIO' $ liftIO $ T.hPutStr port s@@ -672,7 +722,7 @@ flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout  flushPort :: PrimitiveFunc-flushPort = oneArg $ \val -> do+flushPort = oneArg' $ \val -> do   port <- fromEgison val   return $ makeIO' $ liftIO $ hFlush port @@ -680,7 +730,7 @@ readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar  readCharFromPort :: PrimitiveFunc-readCharFromPort = oneArg $ \val -> do+readCharFromPort = oneArg' $ \val -> do   port <- fromEgison val   c <- liftIO $ hGetChar port   return $ makeIO $ return (Char c)@@ -689,13 +739,13 @@ readLine = noArg $ return $ makeIO $ liftIO $ liftM toEgison T.getLine  readLineFromPort :: PrimitiveFunc-readLineFromPort = oneArg $ \val -> do+readLineFromPort = oneArg' $ \val -> do   port <- fromEgison val   s <- liftIO $ T.hGetLine port   return $ makeIO $ return $ toEgison s  readFile' :: PrimitiveFunc-readFile' =  oneArg $ \val -> do+readFile' =  oneArg' $ \val -> do   filename <- fromEgison val   s <- liftIO $ T.readFile $ T.unpack filename   return $ makeIO $ return $ toEgison s@@ -704,13 +754,13 @@ isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF  isEOFPort :: PrimitiveFunc-isEOFPort = oneArg $ \val -> do+isEOFPort = oneArg' $ \val -> do   port <- fromEgison val   b <- liftIO $ hIsEOF port   return $ makeIO $ return (Bool b)  randRange :: PrimitiveFunc-randRange = twoArgs $ \val val' -> do+randRange = twoArgs' $ \val val' -> do   i <- fromEgison val :: EgisonM Integer   i' <- fromEgison val' :: EgisonM Integer   n <- liftIO $ getStdRandom $ randomR (i, i')@@ -718,7 +768,7 @@   {-- -- for 'egison-sqlite' sqlite :: PrimitiveFunc-sqlite  = twoArgs $ \val val' -> do+sqlite  = twoArgs' $ \val val' -> do   dbName <- fromEgison val   qStr <- fromEgison val'   ret <- liftIO $ query' (T.pack dbName) $ T.pack qStr

@@ -15,6 +15,8 @@       EgisonTopExpr (..)     , EgisonExpr (..)     , EgisonPattern (..)+    , Arg (..)+    , Index (..)     , InnerExpr (..)     , BindingExpr (..)     , MatchClause (..)@@ -22,27 +24,37 @@     , LoopRange (..)     , PrimitivePatPattern (..)     , PrimitiveDataPattern (..)+    , Matcher (..)+    , PrimitiveFunc (..)+    , EgisonData (..)+    , showTSV     -- * Egison values     , EgisonValue (..)     , ScalarData (..)     , PolyExpr (..)     , TermExpr (..)     , SymbolExpr (..)-    , TensorData (..)     , Tensor (..)-    , scalarToUnitTensor-    , scalarToTensor-    , tMap-    , tMap2-    , tCheckIndex-    , tContract-    , tref-    , tref'+    , HasTensor (..)+    -- * Tensor+    , initTensor     , tSize     , tToList     , tIndex-    , makeTensor-    , tensorIndices+    , tref+    , enumTensorIndices+    , tMap+    , tMap2+    , tMapN+    , tSum+    , tProduct+    , tContract+    , tContract'+    , tConcat+    , tConcat'+    , tClearIndex+    , tClearIndex'+    -- * Scalar     , symbolScalarData     , mathExprToEgison     , egisonToScalarData@@ -51,17 +63,14 @@     , mathSymbolFold     , mathTermFold     , mathRemoveZero-    , mathReduceFraction-    , mathReduceSymbolFraction+    , mathDivide     , mathPlus     , mathMult     , mathNegate     , mathNumerator     , mathDenominator-    , Matcher (..)-    , PrimitiveFunc (..)-    , EgisonData (..)-    , showTSV+    , extractScalar+    , extractScalar'     -- * Internal data     , Object (..)     , ObjectRef (..)@@ -113,13 +122,13 @@     , isInteger     , isRational     , isSymbol-    , isNumber+    , isScalar     , isTensor     , isTensorWithIndex     , isBool'     , isInteger'     , isRational'-    , isNumber'+    , isScalar'     , isFloat'     , isComplex'     , isTensor'@@ -147,6 +156,7 @@ import Data.Monoid (Monoid) import qualified Data.HashMap.Lazy as HL import qualified Data.Array as Array+import qualified Data.Vector as V import qualified Data.Sequence as Sq import Data.Sequence (Seq) import Data.Foldable (foldr, toList)@@ -154,7 +164,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List (intercalate, sort, sortBy)+import Data.List (intercalate, sort, sortBy, findIndex, splitAt, (\\), elem, delete, deleteBy, any) import Data.Text (Text) import qualified Data.Text as T @@ -169,7 +179,8 @@ --  data EgisonTopExpr =-    Define String EgisonExpr+    Define Var EgisonExpr+  | Redefine Var EgisonExpr   | Test EgisonExpr   | Execute EgisonExpr     -- temporary : we will replace load to import and export@@ -184,19 +195,21 @@   | IntegerExpr Integer   | FloatExpr Double Double   | VarExpr String-  | IndexedExpr EgisonExpr [EgisonExpr]+  | FreshVarExpr+  | IndexedExpr EgisonExpr [Index EgisonExpr]   | PowerExpr EgisonExpr EgisonExpr   | InductiveDataExpr String [EgisonExpr]   | TupleExpr [EgisonExpr]   | CollectionExpr [InnerExpr]   | ArrayExpr [EgisonExpr]   | HashExpr [(EgisonExpr, EgisonExpr)]-  | TensorExpr EgisonExpr EgisonExpr+  | VectorExpr [EgisonExpr] -  | LambdaExpr [String] EgisonExpr+  | LambdaExpr [Arg] EgisonExpr   | MemoizedLambdaExpr [String] EgisonExpr   | MemoizeExpr [(EgisonExpr, EgisonExpr, EgisonExpr)] EgisonExpr   | CambdaExpr String EgisonExpr+  | ProcedureExpr [String] EgisonExpr   | MacroExpr [String] EgisonExpr   | PatternFunctionExpr [String] EgisonPattern   @@ -204,6 +217,7 @@   | LetRecExpr [BindingExpr] EgisonExpr   | LetExpr [BindingExpr] EgisonExpr   | LetStarExpr [BindingExpr] EgisonExpr+  | WithSymbolsExpr [String] EgisonExpr    | MatchExpr EgisonExpr EgisonExpr [MatchClause]   | MatchAllExpr EgisonExpr EgisonExpr MatchClause@@ -218,6 +232,9 @@   | MatcherBFSExpr MatcherInfo   | MatcherDFSExpr MatcherInfo   | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]++  | QuoteExpr EgisonExpr+  | QuoteFunctionExpr EgisonExpr      | DoExpr [BindingExpr] EgisonExpr   | IoExpr EgisonExpr@@ -234,14 +251,26 @@   | ArrayRefExpr EgisonExpr EgisonExpr    | GenerateTensorExpr EgisonExpr EgisonExpr-  | InitTensorExpr EgisonExpr EgisonExpr EgisonExpr+  | TensorExpr EgisonExpr EgisonExpr EgisonExpr EgisonExpr+  | TensorContractExpr EgisonExpr EgisonExpr   | TensorMapExpr EgisonExpr EgisonExpr   | TensorMap2Expr EgisonExpr EgisonExpr EgisonExpr    | SomethingExpr   | UndefinedExpr- deriving (Show, Eq)+ deriving (Eq) +data Arg =+    ScalarArg String+  | TensorArg String+ deriving (Eq)++data Index a =+    Subscript a+  | Superscript a+  | SupSubscript a+ deriving (Eq)+ data InnerExpr =     ElementExpr EgisonExpr   | SubCollectionExpr EgisonExpr@@ -255,7 +284,6 @@     WildCard   | PatVar String   | ValuePat EgisonExpr-  | RegexPat EgisonExpr   | PredPat EgisonExpr   | IndexedPat EgisonPattern [EgisonExpr]   | LetPat [BindingExpr] EgisonPattern@@ -268,8 +296,13 @@   | LoopPat String LoopRange EgisonPattern EgisonPattern   | ContPat   | PApplyPat EgisonExpr [EgisonPattern]-  | DApplyPat EgisonPattern [EgisonPattern]   | VarPat String+  -- For symbolic computing+  | DApplyPat EgisonPattern [EgisonPattern]+  | DivPat EgisonPattern EgisonPattern+  | PlusPat [EgisonPattern]+  | MultPat [EgisonPattern]+  | PowerPat EgisonPattern EgisonPattern  deriving (Show, Eq)  data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern@@ -303,7 +336,7 @@   | String Text   | Bool Bool   | ScalarData ScalarData-  | TensorData TensorData+  | TensorData (Tensor EgisonValue)   | Float Double Double   | InductiveData String [EgisonValue]   | Tuple [EgisonValue]@@ -314,19 +347,22 @@   | StrHash (HashMap Text EgisonValue)   | UserMatcher Env PMMode MatcherInfo   | Func (Maybe String) Env [String] EgisonExpr+  | PartialFunc Env Integer EgisonExpr   | CFunc (Maybe String) Env String EgisonExpr   | MemoizedFunc (Maybe String) 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   | EOF  ----- Scalars+-- Scalar and Tensor Types --  data ScalarData =@@ -335,21 +371,86 @@  data PolyExpr =     Plus [TermExpr]- deriving (Eq)  data TermExpr =     Term Integer [(SymbolExpr, Integer)]- deriving (Eq)  data SymbolExpr =-    Symbol String [Integer]+    Symbol String String [Index ScalarData] -- ID, Name, Indices   | Apply EgisonValue [ScalarData]+  | Quote ScalarData  deriving (Eq) +instance Eq PolyExpr where+  (Plus []) == (Plus []) = True+  (Plus (x:xs)) == (Plus ys) =+    case findIndex ((==) x) ys of+      Just i -> let (hs, _:ts) = splitAt i ys in+                  (Plus xs) == (Plus (hs ++ ts))+      Nothing -> False+  _ == _ = False -symbolScalarData :: String -> [Integer] -> EgisonValue-symbolScalarData name js = (ScalarData (Div (Plus [(Term 1 [(Symbol name js, 1)])]) (Plus [(Term 1 [])])))+instance Eq TermExpr where+  (Term a []) == (Term b [])+    | a /= b =  False+    | otherwise = True+  (Term a (x:xs)) == (Term b ys)+    | a /= b =  False+    | otherwise = case findIndex ((==) 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+ deriving (Show)++class HasTensor a where+  tensorElems :: a -> V.Vector a+  tensorSize :: a -> [Integer]+  tensorIndices :: a -> [Index EgisonValue]+  fromTensor :: (Tensor a) -> EgisonM a+  toTensor :: a -> EgisonM (Tensor a)+  undef :: a++instance HasTensor EgisonValue where+  tensorElems (TensorData (Tensor _ xs _)) = xs+  tensorSize (TensorData (Tensor ns _ _)) = ns+  tensorIndices (TensorData (Tensor _ _ js)) = js+  fromTensor (Tensor [] xs []) =+    if V.length xs == 1+      then return $ V.head xs+      else throwError $ InconsistentTensorIndex+  fromTensor t@(Tensor _ _ _) = return $ TensorData t+  fromTensor (Scalar x) = return x+  toTensor (TensorData t) = return t+  toTensor x = return $ Scalar x+  undef = Undefined++instance HasTensor WHNFData where+  tensorElems (Intermediate (ITensor (Tensor _ xs _))) = xs+  tensorSize (Intermediate (ITensor (Tensor ns _ _))) = ns+  tensorIndices (Intermediate (ITensor (Tensor _ _ js))) = js+  fromTensor (Tensor [] xs []) =+    if V.length xs == 1+      then return $ V.head xs+      else throwError $ InconsistentTensorIndex+  fromTensor t@(Tensor _ _ _) = return $ Intermediate $ ITensor t+  fromTensor (Scalar x) = return x+  toTensor (Intermediate (ITensor t)) = return t+  toTensor x = return $ Scalar x+  undef = Value Undefined++--+-- Scalars+--++symbolScalarData :: String -> String -> EgisonValue+symbolScalarData id name = ScalarData (Div (Plus [(Term 1 [(Symbol id name [], 1)])]) (Plus [(Term 1 [])]))+ mathExprToEgison :: ScalarData -> EgisonValue mathExprToEgison (Div p1 p2) = InductiveData "Div" [(polyExprToEgison p1), (polyExprToEgison p2)] @@ -360,8 +461,12 @@ termExprToEgison (Term a xs) = InductiveData "Term" [toEgison a, Collection (Sq.fromList (map symbolExprToEgison xs))]  symbolExprToEgison :: (SymbolExpr, Integer) -> EgisonValue-symbolExprToEgison (Symbol x js, n) = Tuple [InductiveData "Symbol" [toEgison (T.pack x), toEgison js], toEgison n]+symbolExprToEgison (Symbol id x js, n) = Tuple [InductiveData "Symbol" [symbolScalarData id x, Collection (Sq.fromList (map (\j -> case j of+                                                                                                                                     Superscript k -> InductiveData "Sup" [ScalarData k]+                                                                                                                                     Subscript k -> InductiveData "Sub" [ScalarData k]+                                                                                                                             ) js))], toEgison n] symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n]+symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n]  egisonToScalarData :: EgisonValue -> EgisonM ScalarData egisonToScalarData (InductiveData "Div" [p1, p2]) = Div <$> egisonToPolyExpr p1 <*> egisonToPolyExpr p2@@ -375,6 +480,9 @@ egisonToScalarData s1@(InductiveData "Apply" _) = do   s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])   return $ Div (Plus [(Term 1 [s1'])]) (Plus [(Term 1 [])])+egisonToScalarData s1@(InductiveData "Quote" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])+  return $ Div (Plus [(Term 1 [s1'])]) (Plus [(Term 1 [])]) egisonToScalarData val = liftError $ throwError $ TypeMismatch "math expression" (Value val)  egisonToPolyExpr :: EgisonValue -> EgisonM PolyExpr@@ -386,20 +494,63 @@ egisonToTermExpr val = liftError $ throwError $ TypeMismatch "math term expression" (Value val)  egisonToSymbolExpr :: EgisonValue -> EgisonM (SymbolExpr, Integer)-egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, js], n]) = do-  x' <- fromEgison x-  js' <- fromEgison js+egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, (Collection seq)], n]) = do+  let js = toList seq+  js' <- mapM (\j -> case j of+                         InductiveData "Sup" [ScalarData k] -> return (Superscript k)+                         InductiveData "Sub" [ScalarData k] -> return (Subscript k)+                         _ -> liftError $ throwError $ TypeMismatch "math symbol expression" (Value j)+               ) js   n' <- fromEgison n-  return (Symbol (T.unpack x') js', n')+  case x of+    (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   mExprs' <- mapM egisonToScalarData (toList mExprs)   n' <- fromEgison n   return (Apply fn mExprs', n')+egisonToSymbolExpr (Tuple [InductiveData "Quote" [mExpr], n]) = do+  mExpr' <- egisonToScalarData mExpr+  n' <- fromEgison n+  return (Quote mExpr', n') egisonToSymbolExpr val = liftError $ throwError $ TypeMismatch "math symbol expression" (Value val)  mathNormalize' :: ScalarData -> ScalarData-mathNormalize' mExpr = mathReduceSymbolFraction (mathReduceFraction (mathRemoveZero (mathFold (mathRemoveZeroSymbol mExpr))))+mathNormalize' mExpr = mathDivide (mathRemoveZero (mathFold (mathRemoveZeroSymbol mExpr))) +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 [(Term a xs)])) =+  case f (Term a xs) ts1 of+    Nothing -> (Div (Plus ts1) (Plus [(Term a xs)]))+    Just ts1' -> (Div (Plus ts1') (Plus [(Term 1 [])]))+ where+  f :: TermExpr -> [TermExpr] -> Maybe [TermExpr]+  f _ [] = Just []+  f t1 (t:ts) = do t' <- f' t1 t+                   ts' <- f t1 ts+                   return (t':ts')+  f' :: TermExpr -> TermExpr -> Maybe TermExpr+  f' (Term a xs) (Term b ys) =+    if b `mod` a == 0+      then do ys' <- g xs ys+              return (Term (b `quot` a) ys')+      else Nothing+  g :: [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> Maybe [(SymbolExpr, Integer)]+  g [] ys = Just ys+  g ((x,n):xs) ys = do+    ys' <- g' (x,n) ys+    g xs ys'+  g' :: (SymbolExpr, Integer) -> [(SymbolExpr, Integer)] -> Maybe [(SymbolExpr, Integer)]+  g' (x, n) [] = Nothing+  g' (x, n) ((y, m):ys) = do+    if (x == y && n <= m)+      then Just ((y, (m - n)):ys)+      else do ys' <- g' (x,n) ys+              return ((y,m):ys')+mathDivide (Div (Plus ts1) (Plus ts2)) = (Div (Plus ts1) (Plus ts2))+ mathRemoveZeroSymbol :: ScalarData -> ScalarData mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) =   let p x = case x of@@ -417,48 +568,6 @@       [] -> Div (Plus []) (Plus [Term 1 []])       _ -> Div (Plus ts1') (Plus ts2') -mathReduceFraction :: ScalarData -> ScalarData-mathReduceFraction (Div (Plus []) (Plus ts2)) = Div (Plus []) (Plus ts2)-mathReduceFraction (Div (Plus ts1) (Plus [])) = Div (Plus ts1) (Plus [])-mathReduceFraction (Div (Plus ts1) (Plus ts2)) =-  let as1 = map (\(Term a _) -> a) ts1 in-  let as2 = map (\(Term a _) -> a) ts2 in-  let flg = case as2 of-              [a2] -> if a2 < 0-                        then -1-                        else 1-              _ -> 1 in-  let d = (foldl gcd (head as1) ((tail as1) ++ as2)) * flg in-  let us1 = map (\(Term a xs) -> Term (a `quot` d) xs) ts1 in-  let us2 = map (\(Term a xs) -> Term (a `quot` d) xs) ts2 in-    Div (Plus us1) (Plus us2)--mathReduceSymbolFraction :: ScalarData -> ScalarData-mathReduceSymbolFraction (Div (Plus ts) (Plus ((Term a xs):[]))) = f xs [] ts- where-  f :: [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> [TermExpr] -> ScalarData-  f [] ret ts = Div (Plus ts) (Plus [Term a ret])-  f ((x, n):xs) ret ts =-    let k = g x ts in-      if n > k-        then f xs (ret ++ [(x, (n - k))]) (h x k ts)-        else f xs ret (h x n ts)-  g :: SymbolExpr -> [TermExpr] -> Integer-  g x ts = minimum (map (\(Term _ xs) -> g' x xs) ts)-  g' :: SymbolExpr -> [(SymbolExpr, Integer)] -> Integer-  g' x [] = 0-  g' x ((y, n):xs) = if x == y-                       then n-                       else g' x xs-  h :: SymbolExpr -> Integer -> [TermExpr] -> [TermExpr]-  h x k ts = map (\(Term a xs) -> Term a (filter (\(y, n) -> n /= 0)-                                                 (map (\(y, n) -> if x == y-                                                                    then (y, (n - k))-                                                                    else (y, n))-                                                      xs)))-                 ts-mathReduceSymbolFraction mExpr = mExpr- mathFold :: ScalarData -> ScalarData mathFold mExpr = (mathTermFold (mathSymbolFold (mathTermFold mExpr))) @@ -540,169 +649,366 @@ mathDenominator (Div _ n) = Div n (Plus [(Term 1 [])])  ----- Tensors+-- ExtractScalar -- -data TensorData =-    TData (Tensor ScalarData) (Maybe [ScalarData])- deriving (Eq)+extractScalar :: EgisonValue -> EgisonM ScalarData+extractScalar (ScalarData mExpr) = return mExpr+extractScalar val = throwError $ TypeMismatch "math expression" (Value val) -data Tensor a = Tensor [Integer] [a]- deriving (Eq)+extractScalar' :: WHNFData -> EgisonM ScalarData+extractScalar' (Value (ScalarData x)) = return x+extractScalar' val = throwError $ TypeMismatch "integer or string" $ val -scalarToUnitTensor :: [Integer] -> ScalarData -> (Maybe [ScalarData]) -> TensorData-scalarToUnitTensor ns x js = makeTensor ns (map (\ms -> if all (\m -> m == (head ms)) (tail ms)-                                                         then x-                                                         else (Div (Plus []) (Plus [(Term 1 [])]))) (tensorIndices ns))-                                                js+--+-- Tensors+-- -scalarToTensor :: [Integer] -> ScalarData -> (Maybe [ScalarData]) -> TensorData-scalarToTensor ns x js = makeTensor ns (map (\ms -> x) (tensorIndices ns)) js+initTensor :: [Integer] -> [a] -> [EgisonValue] -> [EgisonValue] -> (Tensor a)+initTensor ns xs sup sub = Tensor ns (V.fromList xs) ((map Superscript sup) ++ (map Subscript sub)) -makeTensor :: [Integer] -> [ScalarData] -> (Maybe [ScalarData]) -> TensorData-makeTensor ns xs js = TData (Tensor ns xs) js+tSize :: (Tensor a) -> [Integer]+tSize (Tensor ns _ _) = ns+tSize (Scalar _) = [] -tensorIndices :: [Integer] -> [[Integer]]-tensorIndices [] = [[]]-tensorIndices (n:ns) = concat (map (\i -> (map (\is -> i:is) (tensorIndices ns))) [1..n])+tToList :: (Tensor a) -> [a]+tToList (Tensor _ xs _) = V.toList xs+tToList (Scalar x) = [x] -tMap :: (ScalarData -> EgisonM ScalarData) -> TensorData -> EgisonM TensorData-tMap f (TData (Tensor ns xs) js) = do-  xs' <- mapM f xs-  return $ TData (Tensor ns xs') js+tToVector :: (Tensor a) -> V.Vector a+tToVector (Tensor _ xs _) = xs+tToVector (Scalar x) = V.fromList [x] -tMap2 :: (ScalarData -> ScalarData -> EgisonM ScalarData) -> TensorData -> TensorData -> EgisonM TensorData-tMap2 f (TData t1@(Tensor ns1 xs1) (Just js1)) (TData t2@(Tensor ns2 xs2) (Just js2)) = do-  ns2' <- transIndex js1 js2 ns2-  if ns1 == ns2'-    then do ys <- mapM (\is -> do is' <- transIndex js1 js2 is-                                  f (tref' is t1) (tref' is' t2))-                       (tensorIndices ns1)-            return $ makeTensor ns1 ys (Just js1)-    else throwError $ InconsistentTensorSize-tMap2 f (TData t1@(Tensor ns1 xs1) Nothing) (TData t2@(Tensor ns2 xs2) Nothing) = do-  if ns1 == ns2-    then do ys <- mapM (\is -> f (tref' is t1) (tref' is t2))-                       (tensorIndices ns1)-            return $ makeTensor ns1 ys Nothing-    else throwError $ InconsistentTensorSize-tMap2 _ t1 t2 = do-  throwError $ InconsistentTensorIndex -- TODO : new error type+tIndex :: (Tensor a) -> [Index EgisonValue]+tIndex (Tensor _ _ js) = js+tIndex (Scalar _) = [] -tSum :: [Tensor ScalarData] -> (Tensor ScalarData)-tSum (t:ts) = tSum' t ts- where-  tSum' :: (Tensor ScalarData) -> [Tensor ScalarData] -> (Tensor ScalarData)-  tSum' (Tensor ns xs) [] = Tensor ns xs-  tSum' (Tensor ns xs) ((Tensor _ xs1):ts) =-    tSum' (Tensor ns (map (\(x,y) -> mathNormalize' (mathPlus x y)) (zip xs xs1))) ts+tIntRef' :: HasTensor a => Integer -> (Tensor a) -> EgisonM a+tIntRef' i (Tensor [_] xs _) = fromTensor $ Scalar $ xs V.! (fromIntegral (i - 1))+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+tIntRef' i _ = throwError $ strMsg "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"+tIntRef [] t = return t+tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms  -transIndex :: [ScalarData] -> [ScalarData] -> [Integer] -> EgisonM [Integer]-transIndex [] [] [] = return []+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"+tref [] t = fromTensor t+tref ((Subscript (ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])))):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref ((Superscript (ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])))):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref ((SupSubscript (ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])))):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref ((Subscript (Tuple [ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])), ScalarData (Div (Plus [(Term n [])]) (Plus [(Term 1 [])]))])):ms) t = do+  ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n]+  symId <- fresh+  tConcat (Subscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor+tref ((Superscript (Tuple [ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])), ScalarData (Div (Plus [(Term n [])]) (Plus [(Term 1 [])]))])):ms) t = do+  ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n]+  symId <- fresh+  tConcat (Superscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor+tref ((SupSubscript (Tuple [ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])), ScalarData (Div (Plus [(Term n [])]) (Plus [(Term 1 [])]))])):ms) t = 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 $ strMsg "More indices than the order of the tensor"++enumTensorIndices :: [Integer] -> [[Integer]]+enumTensorIndices [] = [[]]+enumTensorIndices (n:ns) = concat (map (\i -> (map (\is -> i:is) (enumTensorIndices ns))) [1..n])++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 tjs2 == []-    then throwError $ InconsistentTensorIndex+    then do throwError $ InconsistentTensorIndex     else do let n = (length hjs2) + 1             rs <- transIndex js1 (hjs2 ++ (tail tjs2)) ((take (n - 1) is) ++ (drop n is))-            return ((is !! (n - 1)):rs)+            return ((nth (fromIntegral n) is):rs) transIndex _ _ _ = throwError $ InconsistentTensorSize -tContract :: TensorData -> EgisonM EgisonValue-tContract (TData t@(Tensor ns xs) (Just js)) = do-  case (findPairs js) of-    [] -> return $ TensorData (TData (Tensor ns xs) (Just js))-    ((hs,ms,ts):_) -> do-      let hn = (length hs) + 1-      let mn = (length (hs ++ ms)) + 2-      if (ns !! (hn - 1)) == (ns !! (mn - 1))-        then do-          let n = ns !! (hn - 1)-          let ret = TData (tSum (map (\i -> (tref (hs ++ [(Div (Plus [(Term i [])]) (Plus [(Term 1 [])]))] ++ ms-                                                      ++ [(Div (Plus [(Term i [])]) (Plus [(Term 1 [])]))] ++ ts) t))-                                     [1..n]))-                          (Just (hs ++ ms ++ ts))-          case ret of-            (TData (Tensor [] [x]) (Just [])) -> return $ ScalarData x-            _ -> return $ TensorData ret-        else throwError $ InconsistentTensorIndex+tTranspose :: HasTensor a => [Index EgisonValue] -> (Tensor a) -> EgisonM (Tensor a)+tTranspose is t@(Tensor ns xs js) = do+  ns' <- transIndex js is ns+  xs' <- mapM (transIndex js is) (enumTensorIndices ns') >>= mapM (flip tIntRef t) >>= mapM fromTensor >>= return . V.fromList+  return $ Tensor ns' xs' is++tMap :: HasTensor a => (a -> EgisonM a) -> (Tensor a) -> EgisonM (Tensor a)+tMap f (Tensor ns xs js) = do+  xs' <- V.mapM f xs+  t <- toTensor (V.head xs')+  case t of+    (Tensor ns1 _ js1) ->+      tContract' $ Tensor (ns ++ ns1) (V.concat (V.toList (V.map tensorElems xs'))) (js ++ js1)+    _ -> return $ Tensor ns xs' js+tMap f (Scalar x) = f x >>= return . Scalar++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 = mapM fromTensor xs >>= f >>= return . Scalar++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 (cjs, tjs1, tjs2) = h js1 js2+  t1' <- tTranspose (cjs ++ tjs1) t1+  t2' <- tTranspose (cjs ++ tjs2) t2+  let cns = take (length cjs) (tSize t1')+  rts1 <- mapM (flip tIntRef t1') (enumTensorIndices cns)+  rts2 <- mapM (flip tIntRef t2') (enumTensorIndices cns)+  rts' <- mapM (\(t1, t2) -> tProduct f t1 t2) (zip 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-  findPairs :: [ScalarData] -> [([ScalarData], [ScalarData], [ScalarData])]-  findPairs xs = findPairs' [] xs-  findPairs' :: [ScalarData] -> [ScalarData] -> [([ScalarData], [ScalarData], [ScalarData])]-  findPairs' _ [] = []-  findPairs' hs (x:xs) = (findPairs'' hs x xs) ++ (findPairs' (hs ++ [x]) xs)-  findPairs'' :: [ScalarData] -> ScalarData -> [ScalarData] -> [([ScalarData], [ScalarData], [ScalarData])]-  findPairs'' hs x xs =-    let (hxs, txs) = break (\e -> e == x) xs in-    if txs == []-      then []-      else [(hs, hxs, (tail txs))]-tContract (TData _ Nothing) = throwError $ InconsistentTensorIndex -- TODO : new error type+  h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue])+  h js1 js2 = let cjs = filter (\j -> elem j 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 (flip f x) t+tMap2 f (Scalar x) t@(Tensor _ _ _) = tMap (f x) t+tMap2 f (Scalar x1) (Scalar x2) = f x1 x2 >>= return . Scalar -tCheckIndex :: [ScalarData] -> [Integer] -> EgisonM ()-tCheckIndex [] [] = return ()-tCheckIndex ((Div (Plus [(Term m [])]) (Plus [(Term 1 [])])):ms) (n:ns) =-  if (0 < m) && (m <= n)-    then tCheckIndex ms ns-    else throwError $ TensorIndexOutOfBounds m n-tCheckIndex (Div (Plus [(Term 1 [(Symbol _ _, 1)])]) (Plus [(Term 1 [])]):ms) (n:ns) = tCheckIndex ms ns-tCheckIndex (m:_) _ = throwError $ TypeMismatch "symbol or natural number" (Value (ScalarData m))+tDiag :: HasTensor a => Tensor a -> EgisonM (Tensor a)+tDiag t@(Tensor _ _ js) = do+  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 -tref' :: [Integer] -> (Tensor a) -> a-tref' ms (Tensor ns xs) = tref'' ms ns xs+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-  tref'' :: [Integer] -> [Integer] -> [a] -> a-  tref'' [m] [n] xs = xs !! (fromIntegral (m - 1))-  tref'' (m:ms) (n:ns) xs =-    let w = fromIntegral (product ns) in-    let ys = take w (drop (w * (fromIntegral (m - 1))) xs) in-      tref'' ms ns ys+  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) -tref :: [ScalarData] -> (Tensor a) -> (Tensor a)-tref ms (Tensor ns xs) = let rns = map snd (filter (\(m,_) -> (isSymbol (ScalarData m))) (zip ms ns)) in-                         let rxs = tsub' ms ns xs in-                           Tensor rns rxs+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 <- mapM (\(x1,x2) -> f x1 x2) (V.zip xs1 xs2)+                         return (Tensor ns1 ys js1)+      | otherwise -> throwError $ InconsistentTensorSize++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 (cjs1, cjs2, tjs1, tjs2) = h js1 js2+  case cjs1 of+    [] -> do+      xs' <- 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)) >>= return . V.fromList+      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 ((map g cjs1) ++ tjs1 ++ tjs2) ret  where-  tsub' :: [ScalarData] -> [Integer] -> [a] -> [a]-  tsub' [] [] rs = rs-  tsub' (m:ms) (n:ns) xs =-    if isSymbol (ScalarData m)-      then let w = fromIntegral (product ns) in-           let yss = split w xs in-             concat (map (\ys -> tsub' ms ns ys) yss)-      else let i = extractInteger m in-           let w = fromIntegral (product ns) in-           let ys = take w (drop (w * (fromIntegral (i - 1))) xs) in-             tsub' ms ns ys-  split :: Int -> [a] -> [[a]]-  split _ [] = [[]]-  split w xs = let (hs, ts) = splitAt w xs in+  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)+tProduct f (Scalar x) (Tensor ns xs js) = do+  xs' <- mapM (f x) xs+  return $ Tensor ns xs' js+tProduct f (Tensor ns xs js) (Scalar x) = do+  xs' <- mapM (flip f x) xs+  return $ Tensor ns xs' js+tProduct f (Scalar x1) (Scalar x2) = f x1 x2 >>= return . Scalar++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 (\k -> tIntRef' k 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) = do+  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 _ _ = 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)-  extractInteger :: ScalarData -> Integer-  extractInteger (Div (Plus []) (Plus [(Term 1 [])])) = 0-  extractInteger (Div (Plus [(Term i [])]) (Plus [(Term 1 [])])) = i -tSize :: TensorData -> [Integer]-tSize (TData (Tensor ns _) _) = ns+tConcat :: HasTensor a => Index EgisonValue -> [Tensor a] -> EgisonM (Tensor a)+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] -tToList :: (Tensor a) -> [a]-tToList (Tensor _ xs) = xs+tConcat' :: HasTensor a => [Tensor a] -> EgisonM (Tensor a)+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') [] -tIndex :: TensorData -> Maybe [ScalarData]-tIndex (TData (Tensor _ _) js) = js+tClearIndex :: HasTensor a => Tensor a -> Tensor a+tClearIndex (Tensor ns xs js) = Tensor ns xs (tClearIndex' js)+tClearIndex s@(Scalar _) = s +tClearIndex' :: [Index EgisonValue] -> [Index EgisonValue]+tClearIndex' js = reverse (g (reverse js))+ where+  g :: [Index EgisonValue] -> [Index EgisonValue]+  g [] = []+  g ((Superscript (ScalarData (Div (Plus [(Term 1 [(Symbol _ (':':':':':':_) [], 1)])]) (Plus [(Term 1 [])])))):js) = g js+  g ((Subscript (ScalarData (Div (Plus [(Term 1 [(Symbol _ (':':':':':':_) [], 1)])]) (Plus [(Term 1 [])])))):js) = g js+  g ((SupSubscript (ScalarData (Div (Plus [(Term 1 [(Symbol _ (':':':':':':_) [], 1)])]) (Plus [(Term 1 [])])))):js) = g js+  g js = js++getScalar :: (Tensor a) -> EgisonM a+getScalar (Scalar x) = return x+getScalar _ = throwError $ strMsg "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 in -- [i] [i]+  let ts = tail tts in             -- []+  let (hs, tms) = splitAt m hms in -- [] [i]+  let ms = tail tms in             -- []+    (hs, ms, ts)                   -- [] [] []+--+--+--+ type Matcher = EgisonValue  type PrimitiveFunc = WHNFData -> EgisonM WHNFData +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 y) = showComplexFloat x y+  show (VarExpr name) = name+  show (PartialVarExpr n) = "%" ++ show n++  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 ++ ")"++ instance Show EgisonValue where-  show (Char c) = "'" ++ [c] ++ "'"+  show (Char c) = "c#" ++ [c]   show (String str) = "\"" ++ T.unpack str ++ "\""   show (Bool True) = "#t"   show (Bool False) = "#f"   show (ScalarData mExpr) = show mExpr-  show (TensorData tExpr) = show tExpr+--  show (TensorData (Scalar x)) = "invalid scalar:" ++ show x+  show (TensorData (Tensor [_] xs js)) = "[| " ++ unwords (map show (V.toList xs)) ++ " |]" ++ concat (map show js)+  show (TensorData (Tensor [i, j] xs js)) = "[| " ++ f (fromIntegral j) (V.toList xs) ++ "|]" ++ concat (map show js)+   where+    f j [] = ""+    f j xs = "[| " ++ unwords (map show (take j xs)) ++ " |] " ++ f j (drop j xs)+  show (TensorData (Tensor ns xs js)) = "(tensor {" ++ unwords (map show ns) ++ "} {" ++ unwords (map show (V.toList xs)) ++ "} )" ++ concat (map show js)   show (Float x y) = showComplexFloat x y   show (InductiveData name []) = "<" ++ name ++ ">"   show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">"@@ -710,28 +1016,36 @@   show (Collection vals) = if Sq.null vals                              then "{}"                              else "{" ++ unwords (map show (toList vals)) ++ "}"-  show (Array vals) = "[|" ++ unwords (map show $ Array.elems vals) ++ "|]"+  show (Array vals) = "(|" ++ unwords (map show $ Array.elems vals) ++ "|)"   show (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show (CharHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[\"" ++ T.unpack key ++ "\" " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   show (UserMatcher _ BFSMode _) = "#<matcher-bfs>"   show (UserMatcher _ DFSMode _) = "#<matcher-dfs>"-  show (Func Nothing _ names _) = "(lambda [" ++ unwords names ++ "] ...)"+  show (Func Nothing _ args _) = "(lambda [" ++ unwords (map show args) ++ "] ...)"   show (Func (Just name) _ _ _) = name+  show (PartialFunc _ n expr) = show n ++ "#" ++ show expr   show (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)"   show (CFunc (Just name) _ _ _) = name   show (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ unwords names ++ "] ...)"   show (MemoizedFunc (Just name) _ _ _ names _) = name+  show (Proc Nothing _ names _) = "(procedure [" ++ unwords names ++ "] ...)"+  show (Proc (Just name) _ _ _) = name   show (Macro names _) = "(macro [" ++ unwords 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"   show World = "#<world>"   show EOF = "#<eof>" +instance Show Arg where+  show (ScalarArg name) = "$" ++ name+  show (TensorArg name) = "%" ++ name+ instance Show ScalarData where   show (Div p1 (Plus [(Term 1 [])])) = show p1   show (Div p1 p2) = "(/ " ++ show p1 ++ " " ++ show p2 ++ ")"@@ -752,9 +1066,11 @@ showPoweredSymbol (x, n) = show x ++ "^" ++ show n  instance Show SymbolExpr where-  show (Symbol s []) = s-  show (Symbol s js) = s ++ unwords' (map show js)+  show (Symbol _ (':':':':':':_) []) = "#"+  show (Symbol _ s []) = s+  show (Symbol _ s js) = s ++ concat (map show js)   show (Apply fn mExprs) = "(" ++ show fn ++ " " ++ unwords (map show mExprs) ++ ")"+  show (Quote mExprs) = "'" ++ show mExprs  showComplex :: (Num a, Eq a, Ord a, Show a) => a -> a -> String showComplex x 0 = show x@@ -764,18 +1080,9 @@ showComplexFloat :: Double -> Double -> String showComplexFloat x 0.0 = showFFloat Nothing x "" showComplexFloat 0.0 y = showFFloat Nothing y "i"-showComplexFloat x y = showFFloat Nothing x "" ++ if y > 0 then "+" else "" ++ showFFloat Nothing y "i"--instance Show TensorData where-  show (TData xs Nothing) = show xs-  show (TData xs (Just indices)) = show xs ++ unwords' (map show indices)--unwords' [] = ""-unwords' (x:xs) = "_" ++ x ++ unwords' xs--instance Show (Tensor ScalarData) where-  show (Tensor ns xs) =  "(| {" ++ unwords (map show ns) ++ "} {" ++ unwords (map show xs) ++ "} |)"-+showComplexFloat x y = showFFloat Nothing x "" ++ if y > 0+                                                    then "+" ++ showFFloat Nothing y "i"+                                                    else showFFloat Nothing y "i"  showTSV :: EgisonValue -> String showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map showTSV vals)@@ -787,7 +1094,7 @@  (String str) == (String str') = str == str'  (Bool b) == (Bool b') = b == b'  (ScalarData x) == (ScalarData y) = (x == y)- (TensorData x) == (TensorData y) = (x == y)+ (TensorData (Tensor js xs _)) == (TensorData (Tensor js' xs' _)) = (js == js') && (xs == xs')  (Float x y) == (Float x' y') = (x == x') && (y == y')  (InductiveData name vals) == (InductiveData name' vals') = (name == name') && (vals == vals')  (Tuple vals) == (Tuple vals') = vals == vals'@@ -928,6 +1235,7 @@   | IIntHash (HashMap Integer ObjectRef)   | ICharHash (HashMap Char ObjectRef)   | IStrHash (HashMap Text ObjectRef)+  | ITensor (Tensor WHNFData)  data Inner =     IElement ObjectRef@@ -938,10 +1246,11 @@   show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>"   show (Intermediate (ITuple _)) = "[...]"   show (Intermediate (ICollection _)) = "{...}"-  show (Intermediate (IArray _)) = "[|...|]" +  show (Intermediate (IArray _)) = "(|...|)"    show (Intermediate (IIntHash _)) = "{|...|}"    show (Intermediate (ICharHash _)) = "{|...|}"    show (Intermediate (IStrHash _)) = "{|...|}" +  show (Intermediate (ITensor _)) = "[|...|]"   instance Show Object where   show (Thunk _) = "#<thunk>"@@ -1009,19 +1318,43 @@ -- Environment -- -data Env = Env [HashMap Var ObjectRef]+data Env = Env [HashMap String ObjectRef]  deriving (Show) -type Var = String-type Binding = (Var, ObjectRef)+data Var = Var String [Index ()]+ deriving (Eq)+type Binding = (String, ObjectRef) +instance Show Var where+  show (Var x is) = x ++ concat (map show is)++instance Show (Index ()) where+  show (Superscript ()) = "~"+  show (Subscript ()) = "_"+  show (SupSubscript ()) = "~_"++instance Show (Index EgisonExpr) where+  show (Superscript i) = "~" ++ show i+  show (Subscript i) = "_" ++ show i+  show (SupSubscript i) = "~_" ++ show i++instance Show (Index ScalarData) where+  show (Superscript i) = "~" ++ show i+  show (Subscript i) = "_" ++ show i+  show (SupSubscript i) = "~_" ++ show i++instance Show (Index EgisonValue) where+  show (Superscript i) = "~" ++ show i+  show (Subscript i) = "_" ++ show i+  show (SupSubscript i) = "~_" ++ show i+ nullEnv :: Env nullEnv = Env []  extendEnv :: Env -> [Binding] -> Env extendEnv (Env env) = Env . (: env) . HashMap.fromList -refVar :: Env -> Var -> Maybe ObjectRef+refVar :: Env -> String -> Maybe ObjectRef refVar (Env env) var = msum $ map (HashMap.lookup var) env  --@@ -1042,11 +1375,11 @@  deriving (Show)  data MatchingTree =-    MAtom EgisonPattern ObjectRef Matcher+    MAtom EgisonPattern WHNFData Matcher   | MNode [PatternBinding] MatchingState  deriving (Show) -type PatternBinding = (Var, EgisonPattern)+type PatternBinding = (String, EgisonPattern)  data LoopPatContext = LoopPatContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern  deriving (Show)@@ -1056,7 +1389,7 @@ --  data EgisonError =-    UnboundVariable Var+    UnboundVariable String   | TypeMismatch String WHNFData   | ArgumentsNumWithNames [String] Int Int   | ArgumentsNumPrimitive Int Int@@ -1075,7 +1408,7 @@      instance Show EgisonError where   show (Parser err) = "Parse error at: " ++ err-  show (UnboundVariable var) = "Unbound variable: " ++ var+  show (UnboundVariable var) = "Unbound variable: " ++ show var   show (TypeMismatch expected found) = "Expected " ++  expected ++                                         ", but found: " ++ show found   show (ArgumentsNumWithNames names expected got) = "Wrong number of arguments: " ++ show names ++ ": expected " ++@@ -1250,16 +1583,16 @@ isRational' (Value val) = return $ Value $ Bool $ isRational val  isSymbol :: EgisonValue -> Bool-isSymbol (ScalarData (Div (Plus [(Term 1 [(Symbol _ _, 1)])]) (Plus [(Term 1 [])]))) = True+isSymbol (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ _, 1)])]) (Plus [(Term 1 [])]))) = True isSymbol _ = False -isNumber :: EgisonValue -> Bool-isNumber (ScalarData _) = True-isNumber _ = False+isScalar :: EgisonValue -> Bool+isScalar (ScalarData _) = True+isScalar _ = False -isNumber' :: PrimitiveFunc-isNumber' (Value val) = return $ Value $ Bool $ isNumber val-isNumber' _ = return $ Value $ Bool False+isScalar' :: PrimitiveFunc+isScalar' (Value val) = return $ Value $ Bool $ isScalar val+isScalar' _ = return $ Value $ Bool False  isTensor :: EgisonValue -> Bool isTensor (TensorData _) = True@@ -1270,7 +1603,7 @@ isTensor' _ = return $ Value $ Bool False  isTensorWithIndex :: EgisonValue -> Bool-isTensorWithIndex (TensorData (TData (Tensor _ _) (Just ms))) = True+isTensorWithIndex (TensorData (Tensor _ _ (_:_))) = True isTensorWithIndex _ = False  isTensorWithIndex' :: PrimitiveFunc

@@ -35,14 +35,14 @@                  {[<cons [$x ,1] $rs> {[x rs]}]                   [<cons [$x $n] $rs> {[x {[x (- n 1)] @rs}]}]                   [_ {}]})]}]-       [<ncons ,$k $ $> [a (assoc-list a)]+       [<ncons $ ,$k $> [a (assoc-list a)]         {[$tgt (match tgt (list [something integer])                  {[<cons [$x ,k] $rs> {[x rs]}]                   [<cons [$x (& ?(gt? $ k) $n)] $rs> {[x {[x (- n k)] @rs}]}]                   [_ {}]})]}]-       [<ncons $ $ $> [integer a (assoc-list a)]+       [<ncons $ $ $> [a integer (assoc-list a)]         {[$tgt (match tgt (list [something integer])-                 {[<cons [$x $k] $rs> {[k x rs]}]+                 {[<cons [$x $k] $rs> {[x k rs]}]                   [_ {}]})]}]        [,$val []         {[$tgt (if (eq? val tgt) {[]} {})]}]@@ -72,26 +72,26 @@                   (if (eq? n 1)                     [x {@hs @ts}]                     [x {@hs [x (- n 1)] @ts}])])]}]-       [<ncons ,$n ,$x $> [(assoc-multiset a)]+       [<ncons ,$x ,$n $> [(assoc-multiset a)]         {[$tgt (match-all tgt (list [a integer])                  [<join $hs <cons [,x (& ?(gte? $ n) $k)] $ts>>                   (if (eq? (- k n) 0)                     {@hs @ts}                     {@hs [x (- k n)] @ts})])]}]-       [<ncons ,$n $ $> [a (assoc-multiset a)]+       [<ncons $ ,$n $> [a (assoc-multiset a)]         {[$tgt (match-all tgt (list [a integer])                  [<join $hs <cons [$x (& ?(gte? $ n) $k)] $ts>>                   (if (eq? (- k n) 0)                     [x {@hs @ts}]                     [x {@hs [x (- k n)] @ts}])])]}]-       [<ncons $ ,$x $> [integer (assoc-multiset a)]+       [<ncons ,$x $ $> [integer (assoc-multiset a)]         {[$tgt (match-all tgt (list [a integer])                  [<join $hs <cons [,x $n] $ts>>                   [n {@hs @ts}]])]}]-       [<ncons $ $ $> [integer a (assoc-multiset a)]+       [<ncons $ $ $> [a integer (assoc-multiset a)]         {[$tgt (match-all tgt (list [a integer])                  [<join $hs <cons [$x $n] $ts>>-                  [n x {@hs @ts}]])]}]+                  [x n {@hs @ts}]])]}]        [$ [something]         {[$tgt {tgt}]}]        })))@@ -99,9 +99,9 @@ (define $AC.intersect   (lambda [$xs $ys]     (match-all [xs ys] [(assoc-multiset something) (assoc-multiset something)]-      [[<ncons $m $x _> <ncons $n ,x _>] [x (min m n)]])))+      [[<ncons $x $m _> <ncons ,x $n _>] [x (min m n)]])))  (define $AC.intersect/m   (lambda [$a $xs $ys]     (match-all [xs ys] [(assoc-multiset a) (assoc-multiset a)]-      [[<ncons $m $x _> <ncons $n ,x _>] [x (min m n)]])))+      [[<ncons $x $m _> <ncons ,x $n _>] [x (min m n)]])))

@@ -28,15 +28,15 @@  (define $snd 2#%2) -(define $compose+(define $b.compose   (lambda [$f $g]     (lambda $x       (apply g (apply f x))))) -(define $compose3-  (lambda [$f $g $h]+(define $compose+  (cambda $fs     (lambda $x-      (apply h (apply g (apply f x))))))+      (foldl 2#(%2 %1) x fs))))  (define $ref   (lambda [$xa $i]@@ -51,13 +51,16 @@ ;; ;; Boolean ;;-(define $and+(define $and (cambda $bs (foldl b.and #t bs)))+(define $or (cambda $bs (foldl b.or #f bs)))++(define $b.and   (lambda [$b1 $b2]     (if b1         b2         #f))) -(define $or+(define $b.or   (lambda [$b1 $b2]     (if b1         #t

@@ -21,11 +21,11 @@          [_ {}]}]        [<join $ $> [(list a) (list a)]         {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n))+                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(foldr (lambda [%i %r] {xa_i @r}) {} (between 1 n))                                                          rs]])]}]        [<nioj $ $> [(list a) (list a)]         {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(foldr (lambda [$i $r] {@r xa_i}) {} (between 1 n))+                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(foldr (lambda [%i %r] {@r xa_i}) {} (between 1 n))                                                          rs]])]}]        [,$val []         {[$tgt (if (eq? val tgt) {[]} {})]}]@@ -204,7 +204,7 @@  (define $filter   (lambda [$pred $xs]-    (foldr (lambda [$y $ys] (if (pred y) {y @ys} ys))+    (foldr (lambda [%y %ys] (if (pred y) {y @ys} ys))            {}            xs))) @@ -231,13 +231,13 @@  ; Note. `foldr` is used in the definition of the list matcher. (define $foldr-  (lambda [$fn $init $ls]+  (lambda [$fn %init %ls]     (match ls (list something)       {[<nil> init]        [<cons $x $xs> (fn x (foldr fn init xs))]})))  (define $foldl-  (lambda [$fn $init $ls]+  (lambda [$fn %init %ls]     (match ls (list something)       {[<nil> init]        [<cons $x $xs>@@ -245,17 +245,17 @@           (seq z (foldl fn z xs)))]})))  (define $reduce-  (lambda [$fn $ls]+  (lambda [$fn %ls]     (foldl fn (car ls) (cdr ls))))  (define $scanl-  (lambda [$fn $init $ls]+  (lambda [$fn %init %ls]     {init @(match ls (list something)              {[<nil> {}]               [<cons $x $xs> (scanl fn (fn init x) xs)]})}))  (define $iterate-  (lambda [$fn $x]+  (lambda [$fn %x]     (let* {[$nx1 (fn x)]            [$nx2 (fn nx1)]            [$nx3 (fn nx2)]@@ -263,13 +263,22 @@            [$nx5 (fn nx4)]}       {x nx1 nx2 nx3 nx4 @(iterate fn nx5)}))) +(define $repeated-squaring+  (lambda [$fn %x $n]+    (match n integer+      {[,1 x]+       [?even? (let {[$y (repeated-squaring fn x (quotient n 2))]}+                 (fn y y))]+       [?odd? (let {[$y (repeated-squaring fn x (quotient n 2))]}+                (fn (fn y y) x))]})))+ (define $append   (lambda [$xs $ys]     {@xs @ys}))  (define $concat   (lambda [$xss]-    (foldr (lambda [$xs $rs] {@xs @rs})+    (foldr (lambda [%xs %rs] {@xs @rs})            {}            xss))) @@ -309,11 +318,11 @@                        [hs {x @ms}]])])))))  (define $repeat-  (lambda [$xs]+  (lambda [%xs]     {@xs @(repeat xs)}))  (define $repeat1-  (lambda [$x]+  (lambda [%x]     {x @(repeat1 x)}))  ;;@@ -522,6 +531,14 @@   (lambda [$a $xs]     (let {[$us (unique/m a xs)]}       (map (lambda [$u] [u (count/m a u xs)]) us))))++;;+;; Index+;;+(define $elemIndices+  (lambda [$x $xs]+    (match-all xs (list something)+      [<join $hs <cons ,x _>> (+ 1 (length hs))])))  ;;; ;;; Set

@@ -8,14 +8,14 @@ ;;; IO ;;; (define $print-  (lambda [$x]+  (procedure [$x]     (do {[(write x)]          [(write "\n")]          [(flush)]          })))  (define $print-to-port-  (lambda [$port $x]+  (procedure [$port $x]     (do {[(write-to-port port x)]          [(write-to-port port "\n")]          })))@@ -23,11 +23,11 @@ (define $display (compose show print))  (define $display-to-port-  (lambda [$port $x]+  (procedure [$port $x]     (print-to-port port $ (show x))))  (define $each-line-  (lambda [$proc]+  (procedure [$proc]     (do {[$eof (eof?)]}       (if eof         (return [])@@ -36,7 +36,7 @@           (each-line proc))))))  (define $each-line-from-port-  (lambda [$port $proc]+  (procedure [$port $proc]     (do {[$eof (eof-port? port)]}       (if eof         (return [])@@ -45,7 +45,7 @@           (each-line-from-port port proc))))))  (define $each-file-  (lambda [$files $proc]+  (procedure [$files $proc]     (match files (list string)       {[<nil> (return [])]        [<cons $file $rest>@@ -58,9 +58,17 @@ ;;; Collection ;;; (define $each-  (lambda [$proc $xs]+  (procedure [$proc $xs]     (match xs (list something)       {[<nil> (do {})]        [<cons $x $rs>         (do {[(proc x)]}           (each proc rs))]})))++;;;+;;; Debug+;;;+(define $debug+  (macro [$expr]+    (io (do {[(print (show expr))]}+          (return expr)))))

@@ -162,7 +162,7 @@  (define $regular-continued-fraction-of-sqrt-helper   (lambda [$m $a $b] ; a+b*rt(m)-    (let* {[$n (floor (+ (rtof a) (* (rtof b) (sqrt (rtof m)))))]+    (let* {[$n (floor (f.+ (rtof a) (f.* (rtof b) (sqrt (rtof m)))))]            [$x (- m (power n 2))]}       (if (eq? x 0)         {[a b n]}

@@ -55,4 +55,4 @@                            })]}           (return (read-tsv (S.intercalate "\t" (fn-c copts (fn-s sopts fs)))))))))) -(define $TSV.show (show-tsv $))+(define $TSV.show show-tsv)

@@ -108,8 +108,8 @@  (define $alphabet?   (lambda [$c]-    (or (C.between? 'a' 'z' c)-        (C.between? 'A' 'Z' c))))+    (or (C.between? c#a c#z c)+        (C.between? c#A c#Z c))))  (define $alphabets?   (lambda [$s]@@ -117,12 +117,12 @@  (define $upper-case   (lambda [$c]-    (if (C.between? 'a' 'z' c)+    (if (C.between? c#a c#z c)       (itoc (- (ctoi c) 32))       c)))  (define $lower-case   (lambda [$c]-    (if (C.between? 'A' 'Z' c)+    (if (C.between? c#A c#Z c)       (itoc (+ (ctoi c) 32))       c)))

@@ -26,7 +26,7 @@  (define $q-f   (lambda [$f $x]-    (match (coefficients f x) (list math-expr)+    (match (coefficients x f) (list math-expr)       {[<cons $a_0 <cons $a_1 <cons $a_2 <nil>>>>         (q-f' a_2 a_1 a_0)]}))) @@ -42,7 +42,7 @@  (define $c-f   (lambda [$f $x]-    (match (coefficients f x) (list math-expr)+    (match (coefficients x f) (list math-expr)       {[<cons $a_0 <cons $a_1 <cons $a_2 <cons $a_3 <nil>>>>>         (c-f' a_3 a_2 a_1 a_0)]}))) @@ -50,13 +50,13 @@   (lambda [$a $b $c $d]     (match [a b c d] [math-expr math-expr math-expr math-expr]       {[[,1 ,0 $p $q]-        (let {[[$u3 $v3] (q-f' 1 q (/ (* -1 p^3) 27))]}-          [(+ (rt 3 u3) (rt 3 v3))-           (+ (* w (rt 3 u3)) (* w^2 (rt 3 v3)))-           (+ (* w^2 (rt 3 u3)) (* w (rt 3 v3)))]-          )]-       [[,1 $a2 $a1 $a0]-        (let {[[$y1 $y2 $y3] (c-f' 1 0 (- a1 (/ a2^2 3)) (+ a0 (* (/ -1 3) a1 a2) (* (/ 2 27) a2^3)))]}-          [(- y1 (/ a2 3)) (- y2 (/ a2 3)) (- y3 (/ a2 3))]-          )]+        (let* {[[$s1 $s2] (2#[(rt 3 %1) (rt 3 %2)] (q-f' 1 (* 27 q) (* -27 p^3)))]}+          [(/ (+ s1 s2) 3)               ; r1+           (/ (+ (* w^2 s1) (* w s2)) 3) ; r2+           (/ (+ (* w s1) (* w^2 s2)) 3) ; r3+           ])]+       [[,1 _ _ _]+        (3#[(- %1 (/ b 3)) (- %2 (/ b 3)) (- %3 (/ b 3))]+           (with-symbols {x y}+             (c-f (substitute {[x (- y (/ b 3))]} (+ x^3 (* b x^2) (* c x) d)) y)))]        [[_ _ _ _] (c-f' 1 (/ b a) (/ c a) (/ d a))]})))

@@ -2,6 +2,12 @@ ;;;;; Inverse ;;;;; +(inverse (f x) x)+(f~-1 x)++(inverse (** x 2) x)+;(sqrt x)+ ; (inverse t (* a x^2) x) ; t = (* a x^2) ; x = (sqrt (/ t a))@@ -27,18 +33,14 @@            [<term _ <ncons $n ,x _>>             (let {[$a (/ f (** x n))]}               (inverse (/ t a) (/ f a) x))]-           [_ (inverse' t f x)]})]+           [_ (`inverse t f x)]})]        [?polynomial?-        (match (coefficients f x) (list math-expr)+        (match (coefficients x f) (list math-expr)           {[<cons $c (loop $i [1 $n] <cons ,0 ...> <cons $a <nil>>)>             (inverse (/ (- t c) a) (** x (+ n 1)) x)]-           [_ (inverse' t f x)]})]+           [_ (`inverse t f x)]})]        [_         (match f math-expr           {[<div $p1 $p2>             (inverse (* p2 t) p1 x)]})]-       [_ (inverse' t f x)]})))--(define $inverse'-  (lambda [$t $f $x]-    (to-math-expr <Apply inverse (map from-math-expr {t f x})>)))+       [_ (`inverse t f x)]})))

@@ -0,0 +1,145 @@+;;+;; Matrices+;;++(define $M.*+  (cambda $ms+    (foldl M.b.* (car ms) (cdr ms))))++(define $M.b.*+  (lambda [%m1 %m2]+    (with-symbols {j}+      (. m1~#~j m2_j))))++(define $M.*'+  (cambda $ms+    (foldl M.b.*' (car ms) (cdr ms))))++(define $M.b.*'+  (lambda [%m1 %m2]+    (with-symbols {j}+      (.' m1~#~j m2_j))))++(define $M.power+  (lambda [%m $n]+    (repeated-squaring M.* m n)))+                       +(define $M.comm+  (lambda [%m1 %m2]+    (with-symbols {i j k}+      (- (. m1~i~j m2_j_k) (. m2~i~j m1_j_k)))))++(define $M.inverse+  (lambda [%m]+    (match (tensor-size m) (list integer)+      {[<cons ,2 <cons ,2 <nil>>>+        (T.map (/ $ (M.det m)) (tensor {2 2} {m_2_2 (* -1 m_1_2) (* -1 m_2_1) m_1_1}))]+       [_ undefined]})))++(define $trace (lambda [%t] (with-symbols {i} (contract + t~i_i))))++(define $matrix+  (matcher+    {[<quad-cons $ $ $ $> [math-expr matrix matrix matrix]+      {[$tgt (match (tensor-size tgt) (list integer)+               {[<cons $m <cons $n _>>+                 {[tgt_1_1 tgt_1_[2 n] tgt_[2 m]_1 tgt_[2 m]_[2 n]]}]+                [_ {}]})]}]+     [,$val []+      {[$tgt (if (eq? val tgt) {[]} {})]}]+     [$ [something]+      {[$tgt {tgt}]}]+     }))++;;+;; Determinant+;;++(define $even-and-odd-permutations+  (lambda [$n]+    (match n integer+      {[,2 [{{1 2}} {{2 1}}]]+       [_ (let* {[[$es $os] (even-and-odd-permutations (- n 1))]+                 [$es' (map 1#{@%1 n} es)]+                 [$os' (map 1#{@%1 n} os)]}+            [{@es'+              @(concat (map (lambda [$i] (map (permutate i n $) os')) (between 1 (- n 1))))+              }+             {@os'+              @(concat (map (lambda [$i] (map (permutate i n $) es')) (between 1 (- n 1))))+              }+             ]+            )]})))++(define $permutate+  (lambda [$x $y $xs]+    (match xs (list eq)+      {[<join $hs <cons ,x <join $ms <cons ,y $ts>>>>+        {@hs y @ms x @ts}]+       [<join $hs <cons ,y <join $ms <cons ,x $ts>>>>+        {@hs x @ms y @ts}]})))++(define $M.determinant+  (lambda [%m]+    (match (tensor-size m) (list integer)+      {[<cons $n <cons ,n <nil>>>+        (let {[[$es $os] (even-and-odd-permutations n)]}+          (- (sum (map (lambda [$e]+                         (product (map2 (lambda [$i $j] m_i_j)+                                        (between 1 n)+                                        e)))+                       es))+             (sum (map (lambda [$o]+                         (product (map2 (lambda [$i $j] m_i_j)+                                        (between 1 n)+                                        o)))+                       os))))]+       [_ undefined]})))++(define $M.det M.determinant)++;;;+;;; Eigenvalues and eigenvectors+;;;++(define $M.eigenvalues+  (lambda [%m]+    (match (tensor-size m) (list integer)+      {[<cons ,2 <cons ,2 <nil>>>+        (let {[[$e1 $e2] (q-f (M.det (T.- m (scalar-to-tensor x {2 2}))) x)]}+          {e1 e2})]+       [_ undefined]})))++(define $M.eigenvectors+  (lambda [%m]+    (match (tensor-size m) (list integer)+      {[<cons ,2 <cons ,2 <nil>>>+        (let {[[$e1 $e2] (q-f (M.det (T.- m (scalar-to-tensor x {2 2}))) x)]}+          {[e1 (clear-index (T.- m (scalar-to-tensor e1 {2 2}))_i_1)]+           [e2 (clear-index (T.- m (scalar-to-tensor e2 {2 2}))_i_1)]})+        ]+       [_ undefined]})))++;;+;; LU decomposition+;;++(define $M.LU+  (lambda [%x]+    (match (tensor-size x) (list integer)+      {[<cons ,2 <cons ,2 <nil>>>+        (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[<less> 0] [<equal> 1] [<greater> b_%1_%2]}) {2 2})]+               [$U (generate-tensor 2#(match (compare %1 %2) ordering {[<greater> 0] [_ c_%1_%2]}) {2 2})]+               [$m (M.* L U)]+               [$ret (solve {[m_1_1 x_1_1 c_1_1] [m_1_2 x_1_2 c_1_2]+                             [m_2_1 x_2_1 b_2_1] [m_2_2 x_2_2 c_2_2]})]}+          [(substitute ret L) (substitute ret U)])]+       [<cons ,3 <cons ,3 <nil>>>+        (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[<less> 0] [<equal> 1] [<greater> b_%1_%2]}) {3 3})]+               [$U (generate-tensor 2#(match (compare %1 %2) ordering {[<greater> 0] [_ c_%1_%2]}) {3 3})]+               [$m (M.* L U)]+               [$ret (solve {[m_1_1 x_1_1 c_1_1] [m_1_2 x_1_2 c_1_2] [m_1_3 x_1_3 c_1_3]+                             [m_2_1 x_2_1 b_2_1] [m_2_2 x_2_2 c_2_2] [m_2_3 x_2_3 c_2_3]+                             [m_3_1 x_3_1 b_3_1] [m_3_2 x_3_2 b_3_2] [m_3_3 x_3_3 c_3_3]})]}+          [(substitute ret L) (substitute ret U)])]+       [_ undefined]})))

@@ -13,37 +13,62 @@     (if (integer? n)       (match x math-expr         {[,0 0]-         [?monomial? (rt' n x)]-         [<div <plus $xs> <plus $ys>>+         [?monomial? (rt-monomial n x)]+         [<div <poly $xs> <poly $ys>>           (let {[$xd (reduce gcd xs)]                 [$yd (reduce gcd ys)]}-            (let {[[$a $r] (from-monomial (rt' n (/ xd yd)))]}+            (let {[[$a $r] (from-monomial (rt-monomial n (/ xd yd)))]}               (*' a                  (rt'' n (*' (** r n) (/' (sum' (map (/' $ xd) xs)) (sum' (map (/' $ yd) ys)))))                  )))]})       (rt'' n x)))) -(define $rt'+(define $rt-monomial   (lambda [$n $x]+    (/ (rt-term n (* (numerator x)+                     (** (denominator x) (- n 1))))+       (denominator x))))++(define $rt-term+  (lambda [$n $x]+    (match x term-expr+      {[<term $a _>+        (if (lt? a 0)+          (*' (rtm1 n) (rt-positive-term n (* -1 x)))+          (rt-positive-term n x))]})))++(define $rt-positive-term+  (lambda [$n $x]+    (match [n x] [math-expr math-expr]+      {[[,3 (* $a ,i $r)] (* -1 i (rt 3 (*' a r)))]+       [[_ (* $a (,sqrt $b) $r)] (*' (rt (* n 2) (*' (**' a 2) b)) (rt n r))]+       [[_ (* $a (,rt $n' $b) $r)] (*' (rt (* n n') (*' (**' a n') b)) (rt n r))]+       [[_ _] (rt-positive-term1 n x)]+       })))++(define $rt-positive-term1+  (lambda [$n $x]     (letrec {[$f (lambda [$xs]-                   (match xs (assoc-multiset integer)+                   (match xs (assoc-multiset math-expr)                      {[<nil> [1 1]]-                      [<ncons $k $p $rs>-                       (let {[$ret (f rs)]}-                         [(*' (**' p (quotient k n)) (2#%1 ret)) (*' (**' p (remainder k n)) (2#%2 ret))])]}))]}-      (letrec {[$g (lambda [$x]-                     (match x term-expr-                       {[<term $a $xs>-                         (match (f {@(to-assoc (p-f (abs a))) @xs}) [math-expr math-expr]-                           {[[$x ,1] (if (lt? a 0) (*' (rtm1 n) x) x)]-                            [[$y $z] (if (lt? a 0) (*' (rtm1 n) y (rt'' n z)) (*' y (rt'' n z)))]})]}))]}-        (/' (g (numerator x)) (g (denominator x)))))))+                      [<ncons $p $k $rs>+                       (let {[[$a $b] (f rs)]}+                         [(*' (**' p (quotient k n)) a) (*' (**' p (remainder k n)) b)])]}))]+             [$g (lambda [$n $x]+                   (let {[$d (match x term-expr+                               {[<term $m $xs> (gcd n (reduce gcd (map 2#%2 {@(to-assoc (p-f m)) @xs})))]})]}+                     (rt'' (/ n d) (rt d x))))]}+      (match x term-expr+        {[<term $m $xs>+          (match (f {@(to-assoc (p-f (abs m))) @xs}) [integer integer]+            {[[$a ,1] a]+             [[$a $b] (*' a (g n b))]})]}))))  (define $rt''   (lambda [$n $x]     (match [n x] [integer integer]-      {[[,2 _] (to-math-expr' <Apply sqrt (map from-math-expr {x})>)]-       [[_ _] (to-math-expr' <Apply rt (map from-math-expr {n x})>)]})))+      {[[,2 _] (`sqrt x)]+       [[_ _] (`rt n x)]})))  (define $rtm1   (lambda [$n]@@ -55,7 +80,7 @@  (define $sqrt   (lambda [$x]-    (if (number? x)+    (if (scalar? x)       (let {[$m (numerator x)]             [$n (denominator x)]}         (/ (rt 2 (* m n)) n))@@ -75,6 +100,6 @@          [,2 -1]          [,3 w]          [,4 i]-         [_ (to-math-expr' <Apply rtu (map from-math-expr {n})>)]+         [_ (`rtu n)]          })-      (to-math-expr' <Apply rtu (map from-math-expr {n})>))))+      (`rtu n))))

@@ -4,160 +4,34 @@ ;;;;; ;;;;; -(define $T.map-  (lambda [$fn $t]-    (tensor-map fn t)))--(define $T.map2-  (lambda [$fn $t1 $t2]-    (tensor-map2 fn t1 t2)))--(define $clear-index-  (lambda [$t]-    (| (tensor-size t)-       (tensor-to-list t) |)))- (define $unit-tensor   (lambda [$ns]     (generate-tensor kronecker-delta ns)))  (define $scalar-to-tensor   (lambda [$x $ns]-    (T.map (* x $) (unit-tensor ns))))+    (* x (unit-tensor ns))))  (define $zero-tensor   (lambda [$ns]-    (generate-tensor (cambda $ns 0) ns)))+    (generate-tensor 1#0 ns))) -(define $T.unit (unit-tensor $))-(define $T.zero (zero-tensor $))+(define $b..' (lambda [%t1 %t2] (contract +' (*' t1 t2))))+(define $b.. (lambda [%t1 %t2] (contract + (* t1 t2)))) -;;-;; Arithmetic-;;-(define $T.arith-  (lambda [$op]-    (lambda [$t1 $t2]-      (match [(tensor? t1) (tensor? t2)] [bool bool]-        {[[,#t ,#t] (T.map2 op t1 t2)]-         [[,#t ,#f] (T.map2 op t1 (scalar-to-tensor t2 (tensor-size t1)))]-         [[,#f ,#t] (T.map2 op (scalar-to-tensor t1 (tensor-size t2)) t2)]-         }))))+(define $.+  (cambda $xs+    (match xs (list something)+      {[<join _ <cons (& ?scalar? ?tensor-symbol?) _>> (capply `. xs)]+       [_ (foldl b.. (car xs) (cdr xs))]}))) -(define $T.+ (T.arith +))-(define $T.- (T.arith -))+(define $T.++  (lambda [%t1 %t2]+    (tensor (tensor-size t1)+            (map2 + (tensor-to-list t1) (tensor-to-list t2))))) -;;-;; Vectors-;;-(define $V.*-  (lambda [$v1 $v2]-    (. v1_i v2_i))) -;;-;; Matrices-;;-(define $M.*-  (cambda $ms-    (foldl M.*' (car ms) (cdr ms))))--(define $M.*'-  (lambda [$m1 $m2]-    (clear-index (. m1_i_j m2_j_k))))--(define $M.inverse-  (lambda [$m]-    (match (tensor-size m) (list integer)-      {[<cons ,2 <cons ,2 <nil>>>-        (T.map (/ $ (M.det m)) (| {2 2} {m_2_2 (* -1 m_1_2) (* -1 m_2_1) m_1_1} |))]-       [_ undefined]})))--;;-;; Linear algebra-;;-(define $M.LU-  (lambda [$x]-    (match (tensor-size x) (list integer)-      {[<cons ,2 <cons ,2 <nil>>>-        (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[<less> 0] [<equal> 1] [<greater> b_%1_%2]}) {2 2})]-               [$U (generate-tensor 2#(match (compare %1 %2) ordering {[<greater> 0] [_ c_%1_%2]}) {2 2})]-               [$m (M.* L U)]-               [$ret (solve {[m_1_1 x_1_1 c_1_1] [m_1_2 x_1_2 c_1_2]-                             [m_2_1 x_2_1 b_2_1] [m_2_2 x_2_2 c_2_2]})]}-          [(substitute ret L) (substitute ret U)])]-       [<cons ,3 <cons ,3 <nil>>>-        (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[<less> 0] [<equal> 1] [<greater> b_%1_%2]}) {3 3})]-               [$U (generate-tensor 2#(match (compare %1 %2) ordering {[<greater> 0] [_ c_%1_%2]}) {3 3})]-               [$m (M.* L U)]-               [$ret (solve {[m_1_1 x_1_1 c_1_1] [m_1_2 x_1_2 c_1_2] [m_1_3 x_1_3 c_1_3]-                             [m_2_1 x_2_1 b_2_1] [m_2_2 x_2_2 c_2_2] [m_2_3 x_2_3 c_2_3]-                             [m_3_1 x_3_1 b_3_1] [m_3_2 x_3_2 b_3_2] [m_3_3 x_3_3 c_3_3]})]}-          [(substitute ret L) (substitute ret U)])]-       [_ undefined]})))--;;-;; Determinant-;;-(define $even-and-odd-permutations-  (lambda [$n]-    (match n integer-      {[,2 [{{1 2}} {{2 1}}]]-       [_ (let* {[[$es $os] (even-and-odd-permutations (- n 1))]-                 [$es' (map 1#{@%1 n} es)]-                 [$os' (map 1#{@%1 n} os)]}-            [{@es'-              @(concat (map (lambda [$i] (map (permutate i n $) os')) (between 1 (- n 1))))-              }-             {@os'-              @(concat (map (lambda [$i] (map (permutate i n $) es')) (between 1 (- n 1))))-              }-             ]-            )]})))--(define $permutate-  (lambda [$x $y $xs]-    (match xs (list eq)-      {[<join $hs <cons ,x <join $ms <cons ,y $ts>>>>-        {@hs y @ms x @ts}]-       [<join $hs <cons ,y <join $ms <cons ,x $ts>>>>-        {@hs x @ms y @ts}]})))--(define $M.determinant-  (lambda [$m]-    (match (tensor-size m) (list integer)-      {[<cons $n <cons ,n <nil>>>-        (let {[[$es $os] (even-and-odd-permutations n)]}-          (- (sum (map (lambda [$e]-                         (product (map2 (lambda [$i $j] m_i_j)-                                        (between 1 n)-                                        e)))-                       es))-             (sum (map (lambda [$o]-                         (product (map2 (lambda [$i $j] m_i_j)-                                        (between 1 n)-                                        o)))-                       os))))]-       [_ undefined]})))--(define $M.det M.determinant)--;;;-;;; Eigenvalue-;;;-(define $M.eigenvalues-  (lambda [$m]-    (match (tensor-size m) (list integer)-      {[<cons ,2 <cons ,2 <nil>>>-        (let {[[$e1 $e2] (q-f (M.det (T.- m (scalar-to-tensor x {2 2}))) x)]}-          {e1 e2})]-       [_ undefined]})))--(define $M.eigenvectors-  (lambda [$m]-    (match (tensor-size m) (list integer)-      {[<cons ,2 <cons ,2 <nil>>>-        (let {[[$e1 $e2] (q-f (M.det (T.- m (scalar-to-tensor x {2 2}))) x)]}-          {[e1 (clear-index (T.- m (scalar-to-tensor e1 {2 2}))_i_1)]-           [e2 (clear-index (T.- m (scalar-to-tensor e2 {2 2}))_i_1)]})-        ]-       [_ undefined]})))+(define $T.-+  (lambda [%t1 %t2]+    (tensor (tensor-size t1)+            (map2 - (tensor-to-list t1) (tensor-to-list t2)))))

@@ -0,0 +1,28 @@+;;+;; Vectors+;;++(define $dot-product+  (lambda [%v1 %v2]+    (with-symbols {i}+      (. v1~i v2_i))))++(define $V.* dot-product)++(define $cross-product/fn+  (lambda [$fn %a %b]+    [|(- (fn a_2 b_3)  (fn a_3 b_2))+      (- (fn a_3 b_1)  (fn a_1 b_3))+      (- (fn a_1 b_2)  (fn a_2 b_1))|]))++(define $cross-product+  (lambda [%a %b]+    (cross-product/fn * a b)))++(define $div+  (lambda [%A %xs]+    (trace (∇ A xs))))++(define $rot+  (lambda [%A %xs]+    (cross-product/fn ∂/∂ A xs)))

@@ -4,52 +4,59 @@ ;;;;; ;;;;; -(define $d/d+(define $∂/∂   (lambda [$f $x]     (match f math-expr-      {[?simple-term?-        (match [x f] [symbol-expr symbol-expr]-          {[[<symbol $name> <symbol !,name>] 0]-           [[<symbol $name> <symbol ,name>] 1]-           [[_ (,exp $g)] (* (exp g) (d/d g x))]-           [[_ (,** $g $h)] (* f (d/d (* (log g) h) x))]-           [[_ (,log $g)] (* (/ 1 g) (d/d g x))]-           [[_ (,cos $g)] (* (* -1 (sin g)) (d/d g x))]-           [[_ (,sin $g)] (* (cos g) (d/d g x))]-           [[_ (,sqrt $g)] (* (/ 1 (* 2 (sqrt g))) (d/d g x))]-           })]-       [?term?-        (match f term-expr-          {[<term _ <nil>> 0]-           [<term ,1 <ncons $n $fx <nil>>> (* n (** fx (- n 1)) (d/d fx x))]-           [<term $a <ncons $n $fx $ts>>-            (+ (* a-                  (d/d (** fx n) x)-                  (foldl *' 1 (map 2#(**' %1 %2) ts)))-               (* a-                  (** fx n)-                  (d/d (foldl *' 1 (map 2#(**' %1 %2) ts)) x)))]-           })]-       [?polynomial?-        (match f poly-expr-          {[<plus $ts> (sum (map (d/d $ x) ts))]})]-       [_-        (match f math-expr-          {[<div $p1 $p2>-            (let {[$p1' (d/d p1 x)]-                  [$p2' (d/d p2 x)]}-              (/ (- (* p1' p2) (* p2' p1)) (** p2 2)))]-           })]+      {; symbol+       [,x 1]+       [?symbol? 0]+       ; function application+       [(,exp $g) (* (exp g) (∂/∂ g x))]+       [(,log $g) (* (/ 1 g) (∂/∂ g x))]+       [(,cos $g) (* (* -1 (sin g)) (∂/∂ g x))]+       [(,sin $g) (* (cos g) (∂/∂ g x))]+       [(,sqrt $g) (* (/ 1 (* 2 (sqrt g))) (∂/∂ g x))]+       [(,** $g $h) (* f (∂/∂ (* (log g) h) x))]+       [<apply $g $args>+        (sum (map 2#(* (capply `(add-subscript g %1) args) (∂/∂ %2 x))+                  (zip nats args)))]+       ; quote+       [<quote $g> (∂/∂ g x)]+       ; term (constant)+       [,0 0]+       [(* _ ,1) 0]+       ; term (multiplication)+       [(* ,1 $fx^$n) (* n (** fx (- n 1)) (∂/∂ fx x))]+       [(* $a $fx^$n $r)+        (+ (* a (∂/∂ (**' fx n) x) r)+           (* a (**' fx n) (∂/∂ r x)))]+       ; polynomial+       [<poly $ts> (sum (map (∂/∂ $ x) ts))]+       ; quotient+       [(/ $p1 $p2)+        (let {[$p1' (∂/∂ p1 x)]+              [$p2' (∂/∂ p2 x)]}+          (/ (- (* p1' p2) (* p2' p1)) (** p2 2)))]        }))) -(define $d/dx (d/d $ x)) ; just a syntax sugar-(define $d/dy (d/d $ y)) ; just a syntax sugar-(define $d/dz (d/d $ z)) ; just a syntax sugar+(define $d/d ∂/∂)+(define $pd/pd ∂/∂) +(define $∇ ∂/∂)+(define $nabla ∇)++(define $grad ∇)+ (define $taylor-expansion-  (lambda [$f $x $a]-    (map2 *-          (map 1#(/ (** (- x a) %1) (fact %1)) nats0)-          (map (substitute {[x a]} $) (iterate (d/d $ x) f)))))+  (lambda [%f %xs %as]+    (with-symbols {h}+      (let {[$hs (generate-tensor 1#h_%1 (tensor-size xs))]}+        (map2 *+              (map 1#(/ 1 (fact %1)) nats0)+              (map (compose (V.substitute xs as $)+                            (V.substitute hs (with-symbols {i} (- xs_i as_i)) $))+                   (iterate (compose 1#(∇ %1 xs) 1#(V.* hs %1)) f))))))) -(define $maclaurin-expansion (taylor-expansion $ $ 0))+(define $maclaurin-expansion+  (lambda [%f %xs]+    (multivariate-taylor-expansion f xs (tensor-map 1#0 xs))))

@@ -7,41 +7,37 @@ (define $Sd   (lambda [$x $f]     (match f math-expr-      {[?simple-term?-        (match [x f] [symbol-expr symbol-expr]-          {[[<symbol $name> <symbol !,name>] (* f x)]-           [[<symbol $name> <symbol ,name>] (* (/ 1 2) x^2)]-           [[_ (,exp ,x)] (exp x)]-           [[_ (,cos ,x)] (sin x)]-           [[_ (,sin ,x)] (* -1 (cos x))]-           [[_ (,log ,x)] (multSd x 1 (log x))]-           [[_ ($f $y)] (substitute {[tmpvar y]} (Sd tmpvar (* (f tmpvar) (d/d (inverse tmpvar y x) tmpvar))))]-           [[_ (,** $a ,x)] (/ (** a x) (log a))]-           [[_ (,** $a $y)] (substitute {[tmpvar y]} (Sd tmpvar (* (** a tmpvar) (d/d (inverse tmpvar y x) tmpvar))))]-           [[_ _] (Sd' x f)]-           })]-       [?term?-        (match f term-expr-          {[<term $a <ncons $n ,x $ts>>-            (let {[$b (foldl *' a (map 2#(**' %1 %2) ts))]}-              (if (contain-symbol? x b)-                (Sd' x f)-                (/ (* b (** x (+ n 1))) (+ n 1))))]-           [<term $a $ts>-            (let {[[$fxs $cs] (partition (contain-symbol? x $) (from-assoc ts))]}-              (match fxs (list math-expr)-                {[<nil> (* f x)]-                 [<cons $fx <nil>> (* a (Sd x fx) (foldl *' 1 cs))]-                 [_ (Sd' x f)]}))]})]-       [?polynomial?-        (match f poly-expr-          {[<plus $ts> (sum (map (Sd x $) ts))]})]-       [_-        (match f math-expr-          {[<div $p1 $p2>-            (match (coefficients p2 x) (list math-expr)-              {[<cons $a <nil>> (/ (Sd x p1) a)]-               [_ (Sd' x f)]})]})]+      {; symbols+       [,x (* (/ 1 2) x^2)]+       [<symbol _> (* f x)]+       ; function application+       [(,exp ,x) (exp x)]+       [(,cos ,x) (sin x)]+       [(,sin ,x) (* -1 (cos x))]+       [(,log ,x) (multSd x 1 (log x))]+       [(,** $a ,x) (/ (** a x) (log a))]+       [(,** $a $y) (with-symbols {t}+                      (substitute {[t y]} (Sd t (* (** a t) (d/d (inverse t y x) t)))))]+       [(,Sd $y $g) (`Sd x (`Sd y g))]+       [($f $y) (with-symbols {t}+                  (substitute {[t y]} (Sd t (* (f t) (d/d (inverse t y x) t)))))]+       ; term (constant)+       [,0 0]+       [<term $c <nil>> (* c x)]+       ; term (multiplication)+       [<mult $a <ncons $n ,x $r>>+        (if (contain-symbol? x r)+          (`Sd x f)+          (* (/ a (+ n 1)) (** x (+ n 1)) r))]+       ; polynomial+       [<poly $ts> (sum (map (Sd x $) ts))]+       ; quotient+       [<div <plus $ts> $p2>+        (sum (map 1#(Sd x (/ %1 p2)) ts))]+       [<div $p1 $p2>+        (if (contain-symbol? x p2)+          (`Sd x f)+          (/ (Sd x p1) p2))]        })))  (define $multSd@@ -49,10 +45,6 @@     (let {[$F (Sd x f)]}       (- (* F g)          (Sd x (* F (d/d g x)))))))--(define $Sd'-  (lambda [$x $f]-    (to-math-expr <Apply Sd (map from-math-expr {x f})>)))  (define $dSd   (lambda [$x $a $b $f]

@@ -4,7 +4,7 @@ ;;;;; ;;;;; -(define $to-math-expr (macro [$arg] (math-normalize (apply to-math-expr' arg))))+(define $to-math-expr (macro [$arg] (math-normalize b.+ 0 (apply to-math-expr' arg))))  (define $+' (cambda $xs (foldl b.+' (car xs) (cdr xs)))) (define $-' (cambda $xs (foldl b.-' (car xs) (cdr xs))))@@ -12,18 +12,42 @@ (define $/' b./') (define $.' (cambda $xs (foldl b..' (car xs) (cdr xs)))) -(define $b.+ (macro [$x1 $x2] (math-normalize (b.+' x1 x2))))-(define $b.- (macro [$x1 $x2] (math-normalize (b.-' x1 x2))))-(define $b.* (macro [$x1 $x2] (math-normalize (b.*' x1 x2))))-(define $b./ (macro [$x1 $x2] (math-normalize (b./' x1 x2))))-(define $b.. (macro [$x1 $x2] (math-normalize (b..' x1 x2))))+(define $b.++  (lambda [$x1 $x2]+    (match [x1 x2] [math-expr math-expr]+      {[[<div $p1 (& !,1 $p2)> <div $q1 ,p2>]+        (b./ (b.+ p1 q1) p2)]+       [[_ _] (reduce-fraction (math-normalize b.+' x1 x2))]}))) +(define $b.-+  (lambda [$x1 $x2]+    (match [x1 x2] [math-expr math-expr]+      {[[<div $p1 (& !,1 $p2)> <div $q1 ,p2>]+        (b./ (b.- p1 q1) p2)]+       [[_ _] (reduce-fraction (math-normalize b.-' x1 x2))]})))++(define $b.*+  (lambda [$x1 $x2]+    (reduce-fraction (math-normalize b.*' x1 x2))))++(define $b./+  (lambda [$x1 $x2]+    (reduce-fraction (math-normalize b./' x1 x2))))+ (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 $reduce-fraction+  (lambda [$mexpr]+    (match mexpr math-expr+      {[<div <poly $ts1>+             <poly $ts2>>+        (let {[$d (capply gcd {@ts2 @ts1})]}+          (/' (sum' (map (/' $ d) ts1)) (sum' (map (/' $ d) ts2))))]})))+ (define $sum   (lambda [$xs]     (foldl + 0 xs)))@@ -56,19 +80,21 @@         (if (gte? n 0)           (if (integer? n)             (power x n)-            (to-math-expr <Apply ** (map from-math-expr {x n})>))+            (`** x n))           (/ 1 (** x (neg n))))-        (to-math-expr <Apply ** (map from-math-expr {x n})>)))))+        (`** x n)))))  (define $**'   (lambda [$x $n]-    (if (rational? n)-      (if (gte? n 0)-        (if (integer? n)-          (power' x n)-          (to-math-expr' <Apply ** (map from-math-expr {x n})>))-        (/' 1 (**' x (neg n))))-      (to-math-expr' <Apply ** (map from-math-expr {x n})>))))+    (if (eq? x e)+      (exp n)+      (if (rational? n)+        (if (gte? n 0)+          (if (integer? n)+            (power' x n)+            (`** x n))+          (/' 1 (**' x (neg n))))+        (`** x n)))))  (define $gcd   (cambda $xs@@ -81,13 +107,15 @@ (define $b.gcd   (lambda [$x $y]     (match [x y] [term-expr term-expr]-      {[[<term $a $xs> <term $b $ys>]-        (* (b.gcd' (abs a) (abs b)) (foldl *' 1 (map 2#(**' %1 %2) (AC.intersect xs ys))))]})))+      {[[_ ,0] x]+       [[,0 _] y]+       [[<term $a $xs> <term $b $ys>]+        (*' (b.gcd' (abs a) (abs b)) (foldl *' 1 (map 2#(**' %1 %2) (AC.intersect xs ys))))]})))  (define $b.gcd'   (lambda [$x $y]     (match [x y] [integer integer]-      {[[,0 _] y]-       [[_ ,0] x]+      {[[_ ,0] x]+       [[,0 _] y]        [[_ ?(gte? $ x)] (b.gcd' (modulo y x) x)]        [[_ _] (b.gcd' y x)]})))

@@ -0,0 +1,7 @@+;;;;;+;;;;;+;;;;; Mathematical Constants+;;;;;+;;;;;++(define $pi π)

@@ -12,9 +12,9 @@         (match x term-expr           {[,0 1]            [,1 e]-           [<term $a <cons ,i <cons ,pi <nil>>>> (** -1 a)]-           [_ (to-math-expr <Apply exp (map from-math-expr {x})>)]})-        (to-math-expr <Apply exp (map from-math-expr {x})>)))))+           [<mult $a ,(* i pi)> (** -1 a)]+           [_ (`exp x)]})+        (`exp x)))))  (define $log   (lambda [$x]@@ -23,7 +23,7 @@       (match x math-expr         {[,1 0]          [,e 1]-         [_ (to-math-expr <Apply log (map from-math-expr {x})>)]}))))+         [_ (`log x)]}))))  (define $cos   (lambda [$x]@@ -31,8 +31,9 @@       (b.cos x)       (match x math-expr         {[,0 1]-         [,(* 2 pi) 1]-         [_ (to-math-expr <Apply cos (map from-math-expr {x})>)]}))))+         [<term $n <cons ,π <nil>>> (** -1 (abs n))]+         [<div <mult _ ,π> ,2> 0]+         [_ (`cos x)]}))))  (define $sin   (lambda [$x]@@ -40,7 +41,9 @@       (b.sin x)       (match x math-expr         {[,0 0]-         [_ (to-math-expr <Apply sin (map from-math-expr {x})>)]}))))+         [<mult _ ,π> 0]+         [<div <mult $n ,π> ,2> (** -1 (/ (- (abs n) 1) 2))]+         [_ (`sin x)]}))))  (define $tan   (lambda [$x]@@ -48,7 +51,7 @@       (b.tan x)       (match x math-expr         {[,0 0]-         [_ (to-math-expr <Apply tan (map from-math-expr {x})>)]}))))+         [_ (`tan x)]}))))  (define $cosh   (lambda [$x]@@ -56,7 +59,7 @@       (b.cosh x)       (match x math-expr         {[,0 1]-         [_ (to-math-expr <Apply cosh (map from-math-expr {x})>)]}))))+         [_ (`cosh x)]}))))  (define $sinh   (lambda [$x]@@ -64,7 +67,7 @@       (b.sinh x)       (match x math-expr         {[,0 0]-         [_ (to-math-expr <Apply sinh (map from-math-expr {x})>)]}))))+         [_ (`sinh x)]}))))  (define $tanh   (lambda [$x]@@ -72,8 +75,7 @@       (b.tanh x)       (match x math-expr         {[,0 0]-         [_ (to-math-expr <Apply tanh (map from-math-expr {x})>)]}))))-+         [_ (`tanh x)]}))))  (define $sinc   (lambda [$x]@@ -85,12 +87,16 @@         {[,0 1]          [_ (/ (sin x) x)]})))) - (define $sigmoid   (lambda [$z]     (/ 1 (+ 1 (exp (* -1 z)))))) - (define $kronecker-delta   (cambda $js     (if (all (eq? $ (car js)) (cdr js)) 1 0)))++(define $euler-totient-function+  (lambda [$n]+    (* n+       (product (map (lambda [$p] (- 1 (/ 1 p)))+                     (unique (p-f n)))))))

@@ -11,145 +11,152 @@                {[]}                {})]}]      [$ [math-expr']-      {[<Div $p1 $p2> {<Div p1 p2>}]-       [$tgt {(from-math-expr tgt)}]}]+      {[$tgt {(from-math-expr tgt)}]}]      }))  (define $math-expr'   (matcher-    {[<div $ $> [poly-expr poly-expr]+    {[<div $ $> [math-expr math-expr]       {[<Div $p1 $p2> {[(to-math-expr' p1) (to-math-expr' p2)]}]        [_ {}]}]+     [<poly $> [(multiset math-expr)]+      {[<Div <Plus $ts> <Plus {<Term 1 {}> @{}}>> {(map to-math-expr' ts)}]+       [_ {}]}]+     [<plus $> [plus-expr]+      {[<Div <Plus $ts> <Plus {<Term 1 {}> @{}}>> {(to-math-expr' <Div <Plus ts> <Plus {<Term 1 {}>}>>)}]+       [_ {}]}]+     [<term $ $> [integer (assoc-multiset math-expr)]+      {[<Div <Plus {<Term $n $xs> @{}}> <Plus {<Term 1 {}> @{}}>> {[n (map 2#[(to-math-expr' %1) %2] xs)]}]+       [_ {}]}]+     [<mult $ $> [integer mult-expr]+      {[<Div <Plus {<Term $n $xs> @{}}> <Plus {<Term 1 {}> @{}}>> {[n (product' (map 2#(**' (to-math-expr' %1) %2) xs))]}]+       [_ {}]}]+     [<symbol $> [eq]+      {[<Div <Plus {<Term 1 {[<Symbol $v {}> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {v}]+       [_ {}]}]+     [<symbol $ $> [eq (list index-expr)]+      {[<Div <Plus {<Term 1 {[<Symbol $v $js> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {[v js]}]+       [_ {}]}]+     [<apply $ $> [eq (list math-expr)]+      {[<Div <Plus {<Term 1 {[<Apply $v $mexprs> 1] @{}}> @{}}>+             <Plus {<Term 1 {}> @{}}>> +        {[v (map to-math-expr' mexprs)]}]+       [_ {}]}]+     [<quote $> [math-expr]+      {[<Div <Plus {<Term 1 {[<Quote $mexpr> 1] @{}}> @{}}>+             <Plus {<Term 1 {}> @{}}>>+        {(to-math-expr' mexpr)}]+       [_ {}]}]      [$ [something]       {[$tgt {(to-math-expr' tgt)}]}]      })) -(define $poly-expr-  (matcher-    {[,$val []-      {[$tgt (if (eq? val tgt)-               {[]}-               {})]}]-     [$ [poly-expr']-      {[<Plus $ts> {<Plus ts>}]-       [<Div <Plus $ts> <Plus {<Term 1 {}> @{}}>> {<Plus ts>}]-       [$tgt {(from-math-expr tgt)}]}]-     }))+(define $index-expr+  (algebraic-data-matcher+    {<sub math-expr> <sup math-expr>})) -(define $poly-expr'-  (matcher-    {[<plus $> [(multiset term-expr)]-      {[<Plus $ts> {(map to-math-expr' ts)}]-       [<Div <Plus $ts> <Plus {<Term 1 {}> @{}}>> {(map to-math-expr' ts)}]-       [_ {}]}]-     [$ [something]-      {[$tgt {(to-math-expr' tgt)}]}]-     }))+(define $poly-expr math-expr)+(define $term-expr math-expr)+(define $symbol-expr math-expr) -(define $term-expr+(define $plus-expr   (matcher-    {[,$val []-      {[$tgt (if (eq? val tgt)+    {[<nil> []+      {[$tgt (if (eq? tgt 0)                {[]}                {})]}]-     [<mult ,$val $> [term-expr]-      {[$tgt (if (term? (/ tgt val))-               {(/ tgt val)}-               {})]}]-     [$ [term-expr']-      {[<Term $n $xs> {<Term n xs>}]-       [<Div <Plus {<Term $n $xs> @{}}> <Plus {<Term 1 {}> @{}}>> {<Term n xs>}]-       [$tgt {(from-math-expr tgt)}]}]-     }))--(define $term-expr'-  (matcher-    {[<term $ $> [integer (assoc-multiset symbol-expr)]-      {[<Term $n $xs> {[n (map 2#[(to-math-expr' %1) %2] xs)]}]-       [<Div <Plus {<Term $n $xs> @{}}> <Plus {<Term 1 {}> @{}}>> {[n (map 2#[(to-math-expr' %1) %2] xs)]}]-       [_ {}]}]-     [$ [something]-      {[$tgt {(to-math-expr' tgt)}]}]-     }))--(define $symbol-expr-  (matcher-    {[,$val []-      {[$tgt (if (eq? val tgt)-                 {[]}-                 {})]}]-     [$ [symbol-expr']-      {[<Symbol $v> {<Symbol v>}]-       [<Div <Plus {<Term 1 {[<Symbol $v> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {<Symbol v>}]-       [<Apply $v $mexprs> {<Apply v mexprs>}]-       [<Div <Plus {<Term 1 {[<Apply $v $mexprs> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {<Apply v mexprs>}]-       [$tgt {(from-math-expr tgt)}]}]+     [<cons $ $> [math-expr plus-expr]+      {[$tgt (match-all tgt math-expr+               [<poly <cons $t $ts>> [t (sum' ts)]])]}]+     [$ [math-expr]+      {[$tgt {tgt}]}]      })) -(define $symbol-expr'+(define $mult-expr   (matcher-    {[<symbol $> [string]-      {[<Symbol $v> {v}]-       [<Div <Plus {<Term 1 {[<Symbol $v> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {v}]-       [_ {}]}]-     [<apply $ $> [eq (list math-expr)]-      {[<Apply $v $mexprs> [v mexprs]]-       [<Div <Plus {<Term 1 {[<Apply $v $mexprs> 1] @{}}> @{}}>-             <Plus {<Term 1 {}> @{}}>> {[v (map to-math-expr' mexprs)]}]-       [_ {}]}]-     [$ [something]-      {[$tgt {(to-math-expr' tgt)}]}]+    {[<nil> []+      {[$tgt (match tgt math-expr+               {[,0 {[]}]+                [_ {}]})]}]+     [<cons $ $> [math-expr mult-expr]+      {[$tgt (match tgt math-expr+               {[<term _ $xs>+                 (match-all xs (assoc-multiset math-expr)+                   [<cons $x $rs>+                    [x (product' (map 2#(**' %1 %2) rs))]])]+                [_ {}]})]}]+     [<ncons $ $ $> [math-expr integer mult-expr]+      {[$tgt (match tgt math-expr+               {[<term _ $xs>+                 (match-all xs (list [math-expr integer])+                   [<join $hs <cons [$x $n] $ts>>+                    [x n (product' (map 2#(**' %1 %2) {@hs @ts}))]])]+                [_ {}]})]}]+     [$ [math-expr]+      {[$tgt {tgt}]}]      })) +;;+;; Predicate+;; (define $symbol?   (lambda [$mexpr]     (match mexpr math-expr-      {[<div <plus <cons <term ,1 <cons <symbol _> <nil>>> <nil>>>-             <plus <cons <term ,1 <nil>> <nil>>>>-        #t]+      {[<symbol _ _> #t]        [_ #f]}))) -(define $simple-term?+(define $tensor-symbol?   (lambda [$mexpr]     (match mexpr math-expr-      {[<div <plus <cons <term ,1 <cons _ <nil>>> <nil>>>-             <plus <cons <term ,1 <nil>> <nil>>>>-        #t]-       [,0 #t]+      {[<symbol _ <join _ <cons (| <sub ?symbol?> <sup ?symbol?>) _>>> #t]        [_ #f]}))) +(define $apply?+  (lambda [$mexpr]+    (match mexpr math-expr+      {[<apply _ _> #t]+       [_ #f]})))++(define $simple-term? 1#(or (symbol? %1) (apply? %1)))+ (define $term?   (lambda [$mexpr]     (match mexpr math-expr-      {[<div <plus <cons _ <nil>>>-             <plus <cons <term ,1 <nil>> <nil>>>>-        #t]+      {[<term _ _> #t]        [,0 #t]        [_ #f]})))  (define $polynomial?   (lambda [$mexpr]     (match mexpr math-expr-      {[<div _-             <plus <cons <term ,1 <nil>> <nil>>>>-        #t]+      {[<poly _> #t]        [,0 #t]        [_ #f]})))  (define $monomial?   (lambda [$mexpr]     (match mexpr math-expr-      {[<div <plus <cons <term _ _> <nil>>>-             <plus <cons <term _ _> <nil>>>>+      {[<div <poly <cons <term _ _> <nil>>>+             <poly <cons <term _ _> <nil>>>>         #t]        [,0 #t]        [_ #f]}))) +;;+;; Accessor+;;++(define $symbol-indices+  (lambda [$mexpr]+    (match mexpr math-expr+      {[<symbol _ $js> js]+       [_ undefined]})))+ (define $from-monomial   (lambda [$mexpr]     (match mexpr math-expr-      {[<div <plus <cons <term $a $xs> <nil>>>-             <plus <cons <term $b $ys> <nil>>>>+      {[<div <term $a $xs>+             <term $b $ys>>         [(/ a b)          (/ (foldl *' 1 (map 2#(**' %1 %2) xs))             (foldl *' 1 (map 2#(**' %1 %2) ys)))]]})))@@ -157,10 +164,16 @@ ;; ;; Map ;;+(define $map-polys+  (lambda [$fn $mexpr]+    (match mexpr math-expr+      {[<div $p1 $p2>+        (/' (fn p1) (fn p2))]})))+ (define $map-terms   (lambda [$fn $mexpr]     (match mexpr math-expr-      {[<div <plus $ts1> <plus $ts2>>+      {[<div <poly $ts1> <poly $ts2>>         (/' (foldl +' 0 (map fn ts1))             (foldl +' 0 (map fn ts2)))]}))) @@ -170,10 +183,13 @@                  (match term term-expr                    {[<term $a $xs>                      (*' a (foldl *' 1 (map 2#(match %1 symbol-expr-                                                {[<symbol _> (**' (fn %1) %2)]+                                                {[<symbol _ _> (**' (fn %1) %2)]                                                  [<apply $g $args>-                                                  (** (fn (capply g (map (map-symbols fn $) args)))-                                                      %2)+                                                  (let {[$args'(map (map-symbols fn $) args)]}+                                                    (if (eq? args args')+                                                      (**' %1 %2)+                                                      (**' (fn (capply g args'))+                                                          %2)))                                                   ]})                                             xs)))]}))                mexpr)))@@ -181,7 +197,7 @@ (define $contain-symbol?   (lambda [$x $mexpr]     (any id (match mexpr math-expr-              {[<div <plus $ts1> <plus $ts2>>+              {[<div <poly $ts1> <poly $ts2>>                 (map (lambda [$term]                        (match term term-expr                          {[<term _ $xs>@@ -192,17 +208,50 @@                                         xs))]}))                      {@ts1 @ts2})]})))) +(define $contain-function?+  (lambda [$f $mexpr]+    (any id (match mexpr math-expr+              {[<div <poly $ts1> <poly $ts2>>+                (map (lambda [$term]+                       (match term term-expr+                         {[<term _ $xs>+                           (any id (map 2#(match %1 symbol-expr+                                            {[<apply $g $args>+                                              (if (eq? f g)+                                                #t+                                                (any id (map (contain-function? f $) args)))]+                                             [_ #f]})+                                        xs))]}))+                     {@ts1 @ts2})]}))))++(define $contain-function-with-index?+  (lambda [$mexpr]+    (any id (match mexpr math-expr+              {[<div <poly $ts1> <poly $ts2>>+                (map (lambda [$term]+                       (match term term-expr+                         {[<term _ $xs>+                           (any id (map 2#(match %1 symbol-expr+                                            {[<apply (& ?scalar? $f) $args>+                                              (match f math-expr+                                                {[<symbol _ !<nil>> #t]+                                                 [_ (any id (map (contain-function-with-index? $) args))]})]+                                             [<apply _ $args>+                                              (any id (map (contain-function-with-index? $) args))]+                                             [_ #f]})+                                        xs))]}))+                     {@ts1 @ts2})]}))))+  + ;;; ;;; Substitute ;;; (define $substitute   (lambda [$ls $mexpr]-    (if (tensor? mexpr)-      (tensor-map (substitute ls $) mexpr)-      (match ls (list [symbol-expr math-expr])-        {[<nil> mexpr]-         [<cons [$x $a] $rs>-          (substitute rs (substitute' x a mexpr))]}))))+    (match ls (list [symbol-expr math-expr])+      {[<nil> mexpr]+       [<cons [$x $a] $rs>+        (substitute rs (substitute' x a mexpr))]})))  (define $substitute'   (lambda [$x $a $mexpr]@@ -214,28 +263,32 @@       {[,x a]        [_ sexpr]}))) +(define $V.substitute+  (lambda [%xs %ys $mexpr]+    (substitute (zip (tensor-to-list xs) (tensor-to-list ys)) mexpr)))+ ;;; ;;; Coefficient ;;; (define $coefficients-  (lambda [$f $x]+  (lambda [$x $f]     (let {[$m (capply max {0 @(match-all f math-expr-                                [<div <plus <cons <term $a <ncons $k ,x $ts>> _>> _> k])})]}-      (map (coefficient f x $) (between 0 m)))))+                                [<div <poly <cons <term $a <ncons ,x $k $ts>> _>> _> k])})]}+      (map (coefficient x $ f) (between 0 m)))))  (define $coefficient-  (lambda [$f $x $m]+  (lambda [$x $m $f]     (if (eq? m 0)       (/ (sum (match-all f math-expr-                [<div <plus <cons <term $a (& !<cons ,x _> $ts)> _>> _>+                [<div <poly <cons <term $a (& !<cons ,x _> $ts)> _>> _>                  (foldl *' a (map 2#(**' %1 %2) ts))]))          (denominator f))-      (coefficient' f x m))))+      (coefficient' x m f))))  (define $coefficient'-  (lambda [$f $x $m]+  (lambda [$x $m $f]     (/ (sum (match-all f math-expr-              [<div <plus <cons <term $a <ncons $k ,x $ts>> _>> _>+              [<div <poly <cons <term $a <ncons ,x $k $ts>> _>> _>                (if (eq? m k)                  (foldl *' a (map 2#(**' %1 %2) ts))                  0)]))

@@ -4,71 +4,185 @@ ;;;;; ;;;;; -;(set-term-rewriting-rule {[(rt $n $x)^,n x]-;                          [(* (sqrt $x) (sqrt $y)) (* (gcd x y) (sqrt (/ (* x y) (gcd x y))))]-;                          [(rtu $n)^,n 1]-;                          [w^3 1]-;                          [w^2 (- -1 w)]-;                          [i^2 -1]})- (define $math-normalize-  (lambda [$mexpr]-    (if (tensor? mexpr)-      (tensor-map math-normalize mexpr)-      (if (number? mexpr)-        (if (rational? mexpr)-          mexpr-          (map-terms rewrite-rule-rt-                     (map-terms rewrite-rule-sqrt-                                (map-terms rewrite-rule-rtu-                                           (map-terms rewrite-rule-w-                                                      (map-terms rewrite-rule-i-                                                                 mexpr-                                                                 ))))))-        mexpr))))+  (lambda [$fn $x1 $x2]+    (if (and (integer? x1) (integer? x2))+      (fn x1 x2)+      ((capply compose (map 2#%1 (filter 2#(%2 x1 x2) rewrite-rules))) (fn x1 x2))))) -(define $rewrite-rule-i+(define $rewrite-rules+  {+   [id 2##t]+   [rewrite-rule-for-i 2#(and (contain-symbol? i %1) (contain-symbol? i %2))]+   [rewrite-rule-for-w-term 2#(and (contain-symbol? w %1) (contain-symbol? w %2))]+   [rewrite-rule-for-rtu-term 2#(and (contain-function? rtu %1) (contain-function? rtu %2))]+   [rewrite-rule-for-w-poly 2#(and (contain-symbol? w %1) (contain-symbol? w %2))]+   [rewrite-rule-for-rtu-poly 2#(and (contain-function? rtu %1) (contain-function? rtu %2))]+   [rewrite-rule-for-sqrt 2#(and (contain-function? sqrt %1) (contain-function? sqrt %2))]+   [rewrite-rule-for-rt 2#(and (contain-function? rt %1) (contain-function? rt %2))]+   [rewrite-rule-for-cos-and-sin 2#(or (contain-function? cos %1) (contain-function? sin %1) (contain-function? cos %2) (contain-function? sin %2))]+;   [rewrite-rule-for-∂/∂ 2#(and (contain-function-with-index? %1) (contain-function-with-index? %2))]+   })++;;+;; i+;;++(define $rewrite-rule-for-i rewrite-rule-for-i-term)++(define $rewrite-rule-for-i-term (map-terms rewrite-rule-for-i-term' $))++(define $rewrite-rule-for-i-term'   (lambda [$term]-    (match term term-expr-      {[<term $a <ncons (& ?even? $k) ,i $ts>>-        (*' a (**' -1 (quotient k 2)) (foldl *' 1 (map 2#(**' %1 %2) ts)))]-       [<term $a <ncons $k ,i $ts>>-        (*' a (**' -1 (quotient k 2)) i (foldl *' 1 (map 2#(**' %1 %2) ts)))]+    (match term math-expr+      {[(* $a ,i^(& ?even? $k) $r)+        (*' a (**' -1 (quotient k 2)) r)]+       [(* $a ,i^$k $r)+        (*' a (**' -1 (quotient k 2)) r i)]        [_ term]}))) -(define $rewrite-rule-w+;;+;; w+;;++(define $rewrite-rule-for-w+  (compose rewrite-rule-for-w-term+           rewrite-rule-for-w-poly $))++(define $rewrite-rule-for-w-term (map-terms rewrite-rule-for-w-term' $))+(define $rewrite-rule-for-w-poly (map-polys rewrite-rule-for-w-poly' $))++(define $rewrite-rule-for-w-term'   (lambda [$term]-    (match term term-expr-      {[<term $a <ncons (& ?(gte? $ 3) $k) ,w $ts>>-        (*' a (**' w (remainder k 3)) (foldl *' 1 (map 2#(**' %1 %2) ts)))]-       [<term $a <ncons ,2 ,w $ts>>-        (*' a (- -1 w) (foldl *' 1 (map 2#(**' %1 %2) ts)))]+    (match term math-expr+      {[(* $a ,w^(& ?(gte? $ 3) $k) $r)+        (*' a r (**' w (remainder k 3)))]        [_ term]}))) -(define $rewrite-rule-rtu+(define $rewrite-rule-for-w-poly'+  (lambda [$poly]+    (match poly math-expr+      {[(+ (* $a ,w^,2 $mr)+           (* $b ,w ,mr)+           $pr)+        (rewrite-rule-for-w-poly' (+' pr+                                     (*' -1 a mr)+                                     (*' (- b a) mr w)+                                     ))]+       [_ poly]})))++;;+;; rtu (include i and w)+;;++(define $rewrite-rule-for-rtu+  (compose +           (map-terms rewrite-rule-for-rtu-term $)+           (map-polys rewrite-rule-for-rtu-poly $)+           ))++(define $rewrite-rule-for-rtu-term (map-terms rewrite-rule-for-rtu-term' $))+(define $rewrite-rule-for-rtu-poly (map-polys rewrite-rule-for-rtu-poly' $))++(define $rewrite-rule-for-rtu-term'   (lambda [$term]-    (match term term-expr-      {[<term $a <ncons $k (,rtu (& ?(gte? k $) $n)) $ts>>-        (*' a (**' (rtu n) (remainder k n)) (foldl *' 1 (map 2#(**' %1 %2) ts)))]+    (match term math-expr+      {[(* $a (,rtu $n)^(& ?(gte? $ n) $k) $r)+        (*' a (**' (rtu n) (remainder k n)) r)]        [_ term]}))) -(define $rewrite-rule-sqrt+(define $rewrite-rule-for-rtu-poly'+  (lambda [$poly]+    (match poly math-expr+      {[(+ (* $a (,rtu $n)^,(- n 1) $mr)+           (loop $i [2 ,(- n 1)]+             (+ (* ,a ,(rtu n)^,(- n i) ,mr) ...)+             $pr))+        (rewrite-rule-for-rtu-poly' (+' pr (*' -1 a mr)))]+       [_ poly]})))++;;+;; sqrt+;;++(define $rewrite-rule-for-sqrt (map-terms rewrite-rule-for-sqrt-term $))++(define $rewrite-rule-for-sqrt-term   (lambda [$term]-    (match term term-expr-      {[<term $a <cons (,sqrt $x) <cons (,sqrt ,x) $ts>>>-        (* a x (foldl *' 1 (map 2#(**' %1 %2) ts)))]-       [<term $a <cons (,sqrt (& ?term? $x)) <cons (,sqrt (& ?term? $y)) $ts>>>+    (match term math-expr+      {[(* $a (,sqrt $x) (,sqrt ,x) $r)+        (rewrite-rule-for-sqrt-term (*' a x 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))]}-            (*' a d-               (sqrt (*' a1 a2)) (sqrt x1) (sqrt y1)-               (foldl *' 1 (map 2#(**' %1 %2) ts))))]+          (*' a d+             (sqrt (*' a1 a2)) (sqrt x1) (sqrt y1)+             r))]        [_ term]}))) -(define $rewrite-rule-rt+;;+;; rt (include sqrt)+;;++(define $rewrite-rule-for-rt+  (map-terms rewrite-rule-for-rt-term $))++(define $rewrite-rule-for-rt-term   (lambda [$term]-    (match term term-expr-      {[<term $a <ncons $k (,rt (& ?(gte? k $) $n) $x) $ts>>-        (*' a (**' x (quotient k n)) (**' (rt n x) (remainder k n)) (foldl *' 1 (map 2#(**' %1 %2) ts)))]+    (match term math-expr+      {[(* $a (,rt $n $x)^(& ?(gte? $ n) $k) $r)+        (*' a (**' x (quotient k n)) (**' (rt n x) (remainder k n)) r)]        [_ term]})))++;;+;; cos, sin+;;++(define $rewrite-rule-for-cos-and-sin (map-polys rewrite-rule-for-cos-and-sin-poly $))++(define $rewrite-rule-for-cos-and-sin-poly+  (lambda [$poly]+    (match poly math-expr+      {[(+ (* $a (,cos $θ)^,2 $mr)+           (* ,a (,sin ,θ)^,2 ,mr)+           $pr)+        (rewrite-rule-for-cos-and-sin-poly (+' pr (*' a mr)))]+       [(+ (* $a $mr)+           (* ,(*' -1 a) (,sin $θ)^,2 ,mr)+           $pr)+        (rewrite-rule-for-cos-and-sin-poly (+' (*' a (cos θ)^2 mr)))]+       [(+ (* $a $mr)+           (* ,(*' -1 a) (,cos $θ)^,2 ,mr)+           $pr)+        (rewrite-rule-for-cos-and-sin-poly (+' (*' a (sin θ)^2)))]+       [_ poly]})))++;;+;; d+;;++(define $rewrite-rule-for-d (map-terms rewrite-rule-for-d-term $))++(define $rewrite-rule-for-d-term+  (lambda [$term]+    (match term math-expr+      {[(* _ (,d _) (,d _) _)+        0]+       [_ term]})))++;;+;; ∂/∂+;;++(define $rewrite-rule-for-∂/∂ (map-polys rewrite-rule-for-∂/∂-poly $))++(define $rewrite-rule-for-∂/∂-poly+  (lambda [$poly]+    (match poly math-expr+      {[(+ (* $a <apply (& $g <symbol $f $subs>) $args>^$n $mr)+           (* $b <apply <symbol ,f ?1#(eq?/m (multiset something) subs %1)> ,args>^,n ,mr)+           $pr)+        (+ (* (+ a b) (`g args)^n mr)+           pr)]+       [_ poly]})))

@@ -31,7 +31,7 @@         assertEgisonM m = fromEgisonM m >>= assertString . either show (const "")              collectDefsAndTests (Define name expr) (bindings, tests) =-          ((name, expr) : bindings, tests)+          ((show name, expr) : bindings, tests)         collectDefsAndTests (Test expr) (bindings, tests) =           (bindings, expr : tests)         collectDefsAndTests _ r = r