egison 3.5.10 → 3.6.0

raw patch · 33 files changed

+2457/−546 lines, 33 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• egison.cabal +2/−2
• elisp/egison-mode.el +7/−2
• hs-src/Interpreter/egison.hs +1/−1
• hs-src/Language/Egison.hs +12/−2
• hs-src/Language/Egison/Core.hs +266/−70
• hs-src/Language/Egison/Desugar.hs +43/−19
• hs-src/Language/Egison/Parser.hs +135/−83
• hs-src/Language/Egison/Primitives.hs +179/−172
• hs-src/Language/Egison/Types.hs +612/−74
• lib/core/array.egi +0/−13
• lib/core/assoc.egi +107/−0
• lib/core/collection.egi +47/−3
• lib/core/number.egi +18/−34
• lib/core/order.egi +12/−29
• lib/core/random.egi +4/−0
• lib/core/string.egi +2/−2
• lib/math/algebra/equations.egi +62/−0
• lib/math/algebra/inverse.egi +44/−0
• lib/math/algebra/root.egi +80/−0
• lib/math/algebra/tensor.egi +163/−0
• lib/math/analysis/derivative.egi +55/−0
• lib/math/analysis/integral.egi +61/−0
• lib/math/common/arithmetic.egi +93/−0
• lib/math/common/functions.egi +96/−0
• lib/math/expression.egi +242/−0
• lib/math/normalize.egi +74/−0
• sample/bipartite-graph.egi +5/−5
• sample/graph.egi +1/−1
• sample/n-queen.egi +30/−30
• sample/one-minute-first.egi +1/−1
• sample/randomized-3sat.egi +1/−1
• sample/triangle.egi +1/−1

@@ -1,4 +1,4 @@-Copyright (c) 2011-2015, Satoshi Egi+Copyright (c) 2011-2016, Satoshi Egi  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"),

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.5.10+Version:             3.6.0 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.@@ -59,7 +59,7 @@  Extra-Source-Files:  benchmark/Benchmark.hs -Data-files:          lib/core/*.egi+Data-files:          lib/core/*.egi lib/math/*.egi lib/math/common/*.egi lib/math/algebra/*.egi lib/math/analysis/*.egi                      sample/*.egi sample/io/*.egi                      elisp/egison-mode.el 

@@ -48,14 +48,16 @@      "\\<lambda\\>"      "\\<memoized-lambda\\>"      "\\<memoize\\>"+     "\\<cambda\\>"+     "\\<macro\\>"      "\\<let\\>"      "\\<letrec\\>"      "\\<let\\*\\>"      "\\<if\\>"      "\\<seq\\>"-     "\\<apply\\>"+;     "\\<apply\\>"      "\\<generate-array\\>"-     "\\<array-size\\>"+     "\\<array-bounds\\>"      "\\<array-ref\\>"       "\\<loop\\>"@@ -88,6 +90,7 @@      "|"      "\\\&"      "@"+     "!"      "\\<_\\>"       "\\<assert\\>"@@ -170,6 +173,8 @@         ((equal "load-file" name) 2)         ((equal "execute" name) 2)         ((equal "lambda" name) 2)+        ((equal "cambda" name) 2)+        ((equal "macro" name) 2)         ((equal "memoized-lambda" name) 2)         ((equal "memoize" name) 2)         ((equal "letrec" name) 2)

@@ -216,7 +216,7 @@  showBanner :: IO () showBanner = do-  putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2015 Satoshi Egi"+  putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2016 Satoshi Egi"   putStrLn $ "http://www.egison.org"   putStrLn $ "Welcome to Egison Interpreter!" --  putStrLn $ "** Information **"

@@ -105,12 +105,22 @@  coreLibraries :: [String] coreLibraries =-  [ "lib/core/base.egi"+  [ "lib/math/expression.egi"+  , "lib/math/normalize.egi"+  , "lib/math/common/arithmetic.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/tensor.egi"+  , "lib/core/base.egi"   , "lib/core/collection.egi"+  , "lib/core/assoc.egi"   , "lib/core/order.egi"   , "lib/core/number.egi"   , "lib/core/io.egi"   , "lib/core/random.egi"-  , "lib/core/array.egi"   , "lib/core/string.egi"   ]

@@ -21,6 +21,9 @@     , evalRefDeep     , evalWHNF     , applyFunc+    -- * Array+    , refArray+    , arrayBounds     -- * Environment     , recursiveBind     -- * Pattern matching@@ -29,6 +32,9 @@     , isEmptyCollection     , unconsCollection     , unsnocCollection+    -- * Tuple, Collection+    , tupleToList+    , collectionToList     -- * Utiltiy functions     , packStringValue     ) where@@ -49,9 +55,11 @@ import Data.IORef import Data.Maybe +import qualified Data.HashMap.Lazy as HL import Data.Array ((!)) import qualified Data.Array as Array-import qualified Data.HashMap.Lazy as HL+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap  import Data.Text (Text) import qualified Data.Text as T@@ -70,6 +78,7 @@   forM_ rest $ evalTopExpr env   return env  where+  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@@ -90,6 +99,7 @@   forM_ rest $ evalTopExpr env   return env  where+  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@@ -110,6 +120,7 @@   forM_ rest $ evalTopExpr env   return env  where+  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@@ -143,10 +154,14 @@ evalExpr _ (CharExpr c) = return . Value $ Char c evalExpr _ (StringExpr s) = return $ Value $ toEgison s evalExpr _ (BoolExpr b) = return . Value $ Bool b-evalExpr _ (NumberExpr x y) = return . Value $ reduceFraction (Number x y)+evalExpr _ (IntegerExpr x) = return . Value $ toEgison x evalExpr _ (FloatExpr x y) = return . Value $ Float x y -evalExpr env (VarExpr name) = refVar env name >>= evalRef+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 var)  evalExpr _ (InductiveDataExpr name []) = return . Value $ InductiveData name [] evalExpr env (InductiveDataExpr name exprs) =@@ -171,6 +186,34 @@   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 (InitTensorExpr nsExpr xsExpr jsExpr) = 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+  if product ns == toInteger (length xs)+    then return $ Value $ TensorData (makeTensor ns xs (Just js))+    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   keyWhnfs <- mapM (evalExpr env) keyExprs@@ -195,19 +238,39 @@   makeHashKey :: WHNFData -> EgisonM EgisonHashKey   makeHashKey (Value val) =     case val of-      Number _ _ -> fromEgison val >>= (return . IntKey)+      ScalarData _ -> fromEgison val >>= (return . IntKey)       Char c -> return (CharKey c)       String str -> return (StrKey str)       _ -> throwError $ TypeMismatch "integer or string" $ Value val   makeHashKey whnf = throwError $ TypeMismatch "integer or string" $ whnf  evalExpr env (IndexedExpr expr indices) = do-  array <- evalExpr env expr+  tensor <- evalExpr env expr   indices' <- mapM (evalExprDeep env) indices-  refArray array 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'+ where+  extract :: EgisonValue -> EgisonM ScalarData+  extract (ScalarData s) = return s+  extract val = throwError $ TypeMismatch "scalar expression" (Value val) -evalExpr env (LambdaExpr names expr) = return . Value $ Func env names expr+evalExpr env (LambdaExpr names expr) = return . Value $ Func Nothing env names expr +evalExpr env (CambdaExpr name expr) = return . Value $ CFunc Nothing env name expr++evalExpr env (MacroExpr names expr) = return . Value $ Macro names expr+ evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern  evalExpr env (IfExpr test expr expr') = do@@ -245,7 +308,7 @@  evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do   let body = foldr genLet (ApplyExpr expr $ TupleExpr [VarExpr "#1"]) bindings-  applyFunc (Value $ Func env ["#1"] body) $ Value World+  applyFunc env (Value $ Func Nothing env ["#1"] body) $ Value World  where   genLet (names, expr) expr' =     LetExpr [(["#1", "#2"], ApplyExpr expr $ TupleExpr [VarExpr "#1"])] $@@ -288,11 +351,30 @@   evalExprDeep env expr1   evalExpr env expr2 +evalExpr env (CApplyExpr func arg) = do+  func <- evalExpr env func+  args <- evalExpr env arg >>= collectionToList+  case func of+    Value (MemoizedFunc name ref hashRef env names body) -> do+      indices' <- mapM fromEgison args+      hash <- liftIO $ readIORef hashRef+      case HL.lookup indices' hash of+        Just objRef -> do+          evalRef objRef+        Nothing -> do+          whnf <- applyFunc env (Value (Func Nothing env names body)) (Value (makeTuple args))+          retRef <- newEvalutedObjectRef whnf+          hash <- liftIO $ readIORef hashRef+          liftIO $ writeIORef hashRef (HL.insert indices' retRef hash)+          writeObjectRef ref (Value (MemoizedFunc name ref hashRef env names body))+          return whnf+    _ -> applyFunc env func (Value (makeTuple args))+ evalExpr env (ApplyExpr func arg) = do   func <- evalExpr env func   arg <- evalExpr env arg   case func of-    Value (MemoizedFunc ref hashRef env names body) -> do+    Value (MemoizedFunc name ref hashRef env names body) -> do       indices <- evalWHNF arg       indices' <- mapM fromEgison $ fromTupleValue indices       hash <- liftIO $ readIORef hashRef@@ -300,25 +382,25 @@         Just objRef -> do           evalRef objRef         Nothing -> do-          whnf <- applyFunc (Value (Func env names body)) arg+          whnf <- applyFunc env (Value (Func Nothing env names body)) arg           retRef <- newEvalutedObjectRef whnf           hash <- liftIO $ readIORef hashRef           liftIO $ writeIORef hashRef (HL.insert indices' retRef hash)-          writeObjectRef ref (Value (MemoizedFunc ref hashRef env names body))+          writeObjectRef ref (Value (MemoizedFunc name ref hashRef env names body))           return whnf-    _ -> applyFunc func arg+    _ -> applyFunc env func arg  evalExpr env (MemoizeExpr memoizeFrame expr) = do   mapM (\(x, y, z) -> do x' <- evalExprDeep env x                          case x' of-                           (MemoizedFunc ref hashRef env' names body) -> do+                           (MemoizedFunc name ref hashRef env' names body) -> do                              indices <- evalExprDeep env y                              indices' <- mapM fromEgison $ fromTupleValue indices                              hash <- liftIO $ readIORef hashRef                              ret <- evalExprDeep env z                              retRef <- newEvalutedObjectRef (Value ret)                              liftIO $ writeIORef hashRef (HL.insert indices' retRef hash)-                             writeObjectRef ref (Value (MemoizedFunc ref hashRef env' names body))+                             writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body))                            _ -> throwError $ TypeMismatch "memoized-function" (Value x'))        memoizeFrame   evalExpr env expr@@ -326,21 +408,57 @@ evalExpr env (MatcherBFSExpr info) = return $ Value $ UserMatcher env BFSMode info evalExpr env (MatcherDFSExpr info) = return $ Value $ UserMatcher env DFSMode info -evalExpr env (GenerateArrayExpr (name:[]) (TupleExpr (sizeExpr:[])) expr) =-  generateArray env name sizeExpr expr-evalExpr env (GenerateArrayExpr (name:xs) (TupleExpr (sizeExpr:ys)) expr) = -  generateArray env name sizeExpr (GenerateArrayExpr xs (TupleExpr ys) expr)-evalExpr env (GenerateArrayExpr names size expr) = -  evalExpr env (GenerateArrayExpr names (TupleExpr [size]) expr)+evalExpr env (GenerateArrayExpr fnExpr (fstExpr, lstExpr)) = do+  fN <- (evalExpr env fstExpr >>= fromWHNF) :: EgisonM Integer+  eN <- (evalExpr env lstExpr >>= fromWHNF) :: EgisonM Integer+  xs <- mapM (\n -> (newObjectRef env (ApplyExpr fnExpr (IntegerExpr n)))) [fN..eN]+  return $ Intermediate $ IArray $ Array.listArray (fN, eN) xs -evalExpr env (ArraySizeExpr expr) = -  evalExpr env expr >>= arraySize-  where-    arraySize :: WHNFData -> EgisonM WHNFData-    arraySize (Intermediate (IArray arr)) = return . Value . toEgison $ (snd (Array.bounds arr)) % 1-    arraySize (Value (Array arr))         = return . Value . toEgison $ (snd (Array.bounds arr)) % 1-    arraySize val                         = throwError $ TypeMismatch "array" val+evalExpr env (ArrayBoundsExpr expr) = +  evalExpr env expr >>= arrayBounds +evalExpr env (GenerateTensorExpr fnExpr sizeExpr) = do+  size' <- evalExpr env sizeExpr+  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))+ where+  extractScalar :: EgisonValue -> EgisonM ScalarData+  extractScalar (ScalarData x) = return x+  extractScalar x = throwError $ TypeMismatch "scalar expression" (Value x)++evalExpr env (TensorMapExpr fnExpr tExpr) = do+  fn <- evalExpr env fnExpr+  tVal <- evalExpr env tExpr+  case tVal of+    Value (TensorData t) -> do+      tMap (applyScalarFunc env fn) t >>= (return . Value . TensorData)+    _ -> throwError $ TypeMismatch "tensor" tVal+ 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++evalExpr env (TensorMap2Expr fnExpr t1Expr t2Expr) = do+  fn <- evalExpr env fnExpr+  t1Val <- evalExpr env t1Expr+  t2Val <- evalExpr env t2Expr+  case (t1Val, t2Val) of+    (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+ 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+ evalExpr _ SomethingExpr = return $ Value Something evalExpr _ UndefinedExpr = return $ Value Undefined evalExpr _ expr = throwError $ NotImplemented ("evalExpr for " ++ show expr)@@ -392,50 +510,76 @@ evalWHNF (Intermediate (ITuple refs)) = Tuple <$> mapM evalRefDeep refs evalWHNF coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList) -applyFunc :: WHNFData -> WHNFData -> EgisonM WHNFData-applyFunc (Value (Func env [name] body)) arg = do+applyFunc :: Env -> WHNFData -> WHNFData -> EgisonM WHNFData+applyFunc _ (Value (Func _ env [name] body)) arg = do   ref <- newEvalutedObjectRef arg   evalExpr (extendEnv env $ makeBindings [name] [ref]) body-applyFunc (Value (Func env names body)) arg = do+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 (PrimitiveFunc func)) arg = func arg-applyFunc (Value (IOFunc m)) arg = do+applyFunc _ (Value (CFunc _ env name body)) arg = do+  refs <- fromTuple arg+  seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs)+  col <- liftIO . newIORef $ WHNF $ Intermediate $ ICollection $ seqRef+  if length refs > 0+    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+  evalExpr (extendEnv env $ makeBindings [name] [ref]) body+applyFunc env (Value (Macro names body)) arg = do+  refs <- fromTuple arg+  if length names == length refs+    then evalExpr (extendEnv env $ makeBindings names refs) body+    else throwError $ ArgumentsNumWithNames names (length names) (length refs)+applyFunc _ (Value (PrimitiveFunc _ func)) arg = func arg+applyFunc _ (Value (IOFunc m)) arg = do   case arg of      Value World -> m      _ -> throwError $ TypeMismatch "world" arg-applyFunc val _ = throwError $ TypeMismatch "function" val--generateArray :: Env -> String -> EgisonExpr -> EgisonExpr -> EgisonM WHNFData-generateArray env name sizeExpr expr = do-  size <- evalExpr env sizeExpr >>= fromWHNF >>= return . fromInteger-  elems <- mapM genElem (enumFromTo 1 size)-  return $ Intermediate $ IArray $ Array.listArray (1, size) elems-  where-    genElem :: Integer -> EgisonM ObjectRef-    genElem i = do env' <- bindEnv env name $ toInteger i-                   newObjectRef env' expr-    -    bindEnv :: Env -> String -> Integer -> EgisonM Env-    bindEnv env name i = do-      ref <- newEvalutedObjectRef (Value (Number (i,0) (1,0)))-      return $ extendEnv env [(name, ref)]+applyFunc _ (Value fn@(ScalarData (Div (Plus [(Term 1 [(Symbol name [], 1)])]) (Plus [(Term 1 [])])))) arg = do+  args <- tupleToList arg+  mExprs <- mapM p 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 _ whnf _ = throwError $ TypeMismatch "function" whnf  refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData refArray val [] = return val  refArray (Value (Array array)) (index:indices) = do-  i <- (liftM fromInteger . fromEgison) index-  if (\(a,b) -> if a <= i && i <= b then True else False) $ Array.bounds array-    then refArray (Value (array ! i)) indices-    else return  $ Value Undefined+  if isInteger index+    then do i <- (liftM fromInteger . fromEgison) index+            if (\(a,b) -> if a <= i && i <= b then True else False) $ Array.bounds array+              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+             let (_,size) = Array.bounds array+             elms <- mapM (\arr -> refArray (Value arr) indices) (Array.elems array)+             elmRefs <- mapM newEvalutedObjectRef elms+             return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs+           _  -> throwError $ TypeMismatch "integer or symbol" (Value index) refArray (Intermediate (IArray array)) (index:indices) = do-  i <- (liftM fromInteger . fromEgison) index-  if (\(a,b) -> if a <= i && i <= b then True else False) $ Array.bounds array-    then let ref = array ! i in-           evalRef ref >>= flip refArray indices-    else return  $ Value Undefined+  if isInteger index+    then do i <- (liftM fromInteger . fromEgison) index+            if (\(a,b) -> if a <= i && i <= b then True else False) $ Array.bounds array+              then let ref = array ! i in+                   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+             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+             return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs+           _  -> throwError $ TypeMismatch "integer or symbol" (Value index) refArray (Value (IntHash hash)) (index:indices) = do   key <- fromEgison index   case HL.lookup key hash of@@ -468,6 +612,14 @@     Nothing -> return $ Value Undefined refArray val _ = throwError $ TypeMismatch "array or hash" val +arrayBounds :: WHNFData -> EgisonM WHNFData+arrayBounds val = arrayBounds' val >>= return . Value++arrayBounds' :: WHNFData -> EgisonM EgisonValue+arrayBounds' (Intermediate (IArray arr)) = return $ Tuple [(toEgison (fst (Array.bounds arr))), (toEgison (snd (Array.bounds arr)))]+arrayBounds' (Value (Array arr))         = return $ Tuple [(toEgison (fst (Array.bounds arr))), (toEgison (snd (Array.bounds arr)))]+arrayBounds' val                         = throwError $ TypeMismatch "array" val+ newThunk :: Env -> EgisonExpr -> Object newThunk env expr = Thunk $ evalExpr env expr @@ -488,13 +640,21 @@   let (names, exprs) = unzip bindings   refs <- replicateM (length bindings) $ newObjectRef nullEnv UndefinedExpr   let env' = extendEnv env $ makeBindings names refs-  zipWithM_ (\ref expr ->+  zipWithM_ (\ref (name,expr) ->                case expr of                  MemoizedLambdaExpr names body -> do                    hashRef <- liftIO $ newIORef HL.empty-                   liftIO . writeIORef ref . WHNF . Value $ MemoizedFunc ref hashRef env' names body+                   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)-            refs exprs+            refs bindings   return env'  --@@ -594,7 +754,7 @@     Just pattern -> do       let env'' = extendEnvForNonLinearPatterns env' bindings loops'       indices' <- mapM (evalExpr env'' >=> liftM fromInteger . fromWHNF) indices-      let pattern' = IndexedPat pattern $ map (\i -> NumberExpr (i,0) (1,0)) indices'+      let pattern' = IndexedPat pattern $ map (\i -> IntegerExpr i) indices'       case trees' of         [] -> return $ msingleton $ MState env loops bindings ((MAtom pattern' target matcher):trees)         _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern' target matcher):(MNode penv (MState env' loops' bindings' trees')):trees)@@ -609,7 +769,7 @@   let env' = extendEnvForNonLinearPatterns env bindings loops   case pattern of     NotPat _ -> throwError $ EgisonBug "should not reach here (not pattern)"-    VarPat _ -> throwError $ strMsg "cannot use variable except in pattern function"+    VarPat _ -> throwError $ strMsg $ "cannot use variable except in pattern function:" ++ show pattern      LetPat bindings' pattern' ->       let extractBindings ([name], expr) =@@ -622,21 +782,24 @@     PredPat predicate -> do       func <- evalExpr env' predicate       arg <- evalRef target-      result <- applyFunc func arg >>= fromWHNF+      result <- applyFunc env func arg >>= fromWHNF       if result then return $ msingleton $ (MState env loops bindings trees)                 else return MNil -    ApplyPat func args -> do+    PApplyPat func args -> do       func' <- evalExpr env' func       case func' of         Value (PatternFunc env'' names expr) ->           let penv = zip names args           in return $ msingleton $ MState env loops bindings (MNode penv (MState env'' [] [] [MAtom expr target matcher]) : trees)         _ -> throwError $ TypeMismatch "pattern constructor" func'++    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-      startNumRef <- newEvalutedObjectRef $ Value $ Number ((startNum - 1),0) (1,0)+      startNum <- evalExpr env' start >>= fromWHNF :: (EgisonM Integer)+      startNumRef <- newEvalutedObjectRef $ Value $ toEgison (startNum - 1)       ends' <- evalExpr env' ends       if isPrimitiveValue ends'         then do @@ -651,8 +814,8 @@       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-          nextNumRef <- newEvalutedObjectRef $ Value $ Number ((startNum + 1),0) (1,0)+          startNum <- evalRef startNumRef >>= fromWHNF :: (EgisonM Integer)+          nextNumRef <- newEvalutedObjectRef $ Value $ toEgison (startNum + 1)           ends <- evalRef endsRef           b <- isEmptyCollection ends           if b@@ -790,6 +953,15 @@       refs <- lift $ mapM (newEvalutedObjectRef . Value) vals       concat <$> zipWithM primitiveDataPatternMatch patterns refs     _ -> matchFail+primitiveDataPatternMatch (PDTuplePat patterns) ref = do+  whnf <- lift $ evalRef ref+  case whnf of+    Intermediate (ITuple refs) ->+      concat <$> zipWithM primitiveDataPatternMatch patterns refs+    Value (Tuple vals) -> do+      refs <- lift $ mapM (newEvalutedObjectRef . Value) vals+      concat <$> zipWithM primitiveDataPatternMatch patterns refs+    _ -> matchFail primitiveDataPatternMatch PDEmptyPat ref = do   whnf <- lift $ evalRef ref   isEmpty <- lift $ isEmptyCollection whnf@@ -884,6 +1056,10 @@ -- -- Util --+toListPat :: [EgisonPattern] -> EgisonPattern+toListPat [] = InductivePat "nil" []+toListPat (pat:pats) = InductivePat "cons" [pat, (toListPat pats)]+ fromTuple :: WHNFData -> EgisonM [ObjectRef] fromTuple (Intermediate (ITuple refs)) = return refs fromTuple (Value (Tuple vals)) = mapM (newEvalutedObjectRef . Value) vals@@ -907,6 +1083,26 @@       return $ MCons head (fromCollection tail') fromCollection whnf = throwError $ TypeMismatch "collection" whnf +tupleToList :: WHNFData -> EgisonM [EgisonValue]+tupleToList whnf = do+  val <- evalWHNF whnf+  return $ tupleToList' val+ where+  tupleToList' (Tuple vals) = vals+  tupleToList' val = [val]++collectionToList :: WHNFData -> EgisonM [EgisonValue]+collectionToList whnf = do+  val <- evalWHNF whnf+  return $ collectionToList' val+ where+  collectionToList' (Collection sq) = toList sq++makeTuple :: [EgisonValue] -> EgisonValue+makeTuple [] = Tuple []+makeTuple [x] = x+makeTuple xs = Tuple xs+ -- -- String --@@ -932,13 +1128,13 @@ extractPrimitiveValue :: WHNFData -> Either EgisonError EgisonValue extractPrimitiveValue (Value val@(Char _)) = return val extractPrimitiveValue (Value val@(Bool _)) = return val-extractPrimitiveValue (Value val@(Number _ _)) = return val+extractPrimitiveValue (Value val@(ScalarData _)) = return val extractPrimitiveValue (Value val@(Float _ _)) = return val extractPrimitiveValue whnf = throwError $ TypeMismatch "primitive value" whnf  isPrimitiveValue :: WHNFData -> Bool isPrimitiveValue (Value (Char _)) = True isPrimitiveValue (Value (Bool _)) = True-isPrimitiveValue (Value (Number _ _)) = True+isPrimitiveValue (Value (ScalarData _)) = True isPrimitiveValue (Value (Float _ _)) = True isPrimitiveValue _ = False

@@ -140,9 +140,14 @@ desugar (IndexedExpr expr indices) =    IndexedExpr <$> desugar expr <*> (mapM desugar indices) -desugar (ArraySizeExpr expr) = do+desugar (PowerExpr expr1 expr2) = do+  expr1' <- desugar expr1+  expr2' <- desugar expr2+  return $ ApplyExpr (VarExpr "**'") (TupleExpr [expr1', expr2'])++desugar (ArrayBoundsExpr expr) = do   expr' <- desugar expr-  return $ ArraySizeExpr expr'+  return $ ArrayBoundsExpr expr'  desugar (InductiveDataExpr name exprs) = do    exprs' <- mapM desugar exprs@@ -181,6 +186,14 @@   expr' <- desugar expr   return $ MemoizeExpr memoizeBindings' expr' +desugar (CambdaExpr name expr) = do+  expr' <- desugar expr+  return $ CambdaExpr name expr'++--desugar (MacroExpr names expr) = do+--  expr' <- desugar expr+--  return $ MacroExpr names expr'+ desugar (PatternFunctionExpr names pattern) = do   pattern' <- desugarPattern pattern   return $ PatternFunctionExpr names pattern'@@ -232,29 +245,38 @@   expr1' <- desugar expr1   return $ SeqExpr expr0' expr1' -desugar (ApplyExpr (VarExpr "+") expr) = do-  expr' <- desugar expr-  case expr' of-    args@(TupleExpr (_:_:[])) -> return $ ApplyExpr (VarExpr "+") args-    (TupleExpr (x:args)) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "+"), x, (CollectionExpr (map ElementExpr args))])+desugar (GenerateArrayExpr fnExpr (fstExpr, lstExpr)) = do+  fnExpr' <- desugar fnExpr+  fstExpr' <- desugar fstExpr+  lstExpr' <- desugar lstExpr+  return $ GenerateArrayExpr fnExpr' (fstExpr', lstExpr') -desugar (ApplyExpr (VarExpr "-") expr) = do-  expr' <- desugar expr-  case expr' of-    args@(TupleExpr (_:_:[])) -> return $ ApplyExpr (VarExpr "-") args-    (TupleExpr (x:args)) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "-"), x, (CollectionExpr (map ElementExpr args))])+desugar (GenerateTensorExpr fnExpr sizeExpr) = do+  fnExpr' <- desugar fnExpr+  sizeExpr' <- desugar sizeExpr+  return $ GenerateTensorExpr fnExpr' sizeExpr' -desugar (ApplyExpr (VarExpr "*") expr) = do-  expr' <- desugar expr-  case expr' of-    args@(TupleExpr (_:_:[])) -> return $ ApplyExpr (VarExpr "*") args-    (TupleExpr (x:args)) -> return $ ApplyExpr (VarExpr "foldl") (TupleExpr [(VarExpr "*"), x, (CollectionExpr (map ElementExpr args))])+desugar (TensorMapExpr fnExpr tExpr) = do+  fnExpr' <- desugar fnExpr+  tExpr' <- desugar tExpr+  return $ TensorMapExpr fnExpr' tExpr' +desugar (TensorMap2Expr fnExpr t1Expr t2Expr) = do+  fnExpr' <- desugar fnExpr+  t1Expr' <- desugar t1Expr+  t2Expr' <- desugar t2Expr+  return $ TensorMap2Expr fnExpr' t1Expr' t2Expr'+ desugar (ApplyExpr expr0 expr1) = do   expr0' <- desugar expr0   expr1' <- desugar expr1   return $ ApplyExpr expr0' expr1' +desugar (CApplyExpr expr0 expr1) = do+  expr0' <- desugar expr0+  expr1' <- desugar expr1+  return $ CApplyExpr expr0' expr1'+ desugar (VarExpr name) = do   asks $ maybe (VarExpr name) id . lookup name @@ -291,7 +313,8 @@    collectName (AndPat patterns) = collectNames patterns    collectName (TuplePat patterns) = collectNames patterns    collectName (InductivePat _ patterns) = collectNames patterns-   collectName (ApplyPat _ patterns) = collectNames patterns+   collectName (PApplyPat _ patterns) = collectNames patterns+   collectName (DApplyPat _ patterns) = collectNames patterns    collectName (LoopPat _ (LoopRange _ _ endNumPat) pattern1 pattern2) = collectName endNumPat `S.union` collectName pattern1 `S.union` collectName pattern2 --   collectName (LoopPat _ (LoopRange _ _ endNumPat) pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2    collectName (LetPat _ pattern) = collectName pattern@@ -316,7 +339,8 @@ desugarPattern' (TuplePat patterns)  = TuplePat <$> mapM desugarPattern' patterns desugarPattern' (InductivePat name patterns) = InductivePat name <$> mapM desugarPattern' patterns desugarPattern' (IndexedPat pattern exprs) = IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs-desugarPattern' (ApplyPat expr patterns) = ApplyPat <$> desugar expr <*> mapM desugarPattern' patterns +desugarPattern' (PApplyPat expr patterns) = PApplyPat <$> desugar expr <*> mapM desugarPattern' patterns +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' pattern = return pattern

@@ -89,7 +89,7 @@ -- |Load a libary file loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr] loadLibraryFile file =-  if file =~ "^lib/core"+  if file =~ "^lib/"     then liftIO (getDataFileName file) >>= loadFile     else do homeDir <- liftIO $ getHomeDirectory             loadFile $ homeDir ++ "/.egison/" ++ file@@ -151,18 +151,19 @@ exprs = endBy expr whiteSpace  expr :: Parser EgisonExpr-expr = do expr <- expr'-          option expr $ IndexedExpr expr <$> many1 (try $ char '_' >> expr')+expr = P.lexeme lexer (do expr0 <- expr'+                          expr1 <- option expr0 $ PowerExpr expr0 <$> (try $ char '^' >> expr')+                          option expr1 $ IndexedExpr expr1 <$> many1 (try $ char '_' >> expr'))  expr' :: Parser EgisonExpr expr' = (try partialExpr              <|> try constantExpr              <|> try partialVarExpr-             <|> contExpr              <|> recVarExpr              <|> try varExpr              <|> inductiveDataExpr              <|> try arrayExpr+             <|> try tensorExpr              <|> try tupleExpr              <|> try hashExpr              <|> collectionExpr@@ -170,6 +171,8 @@                          <|> lambdaExpr                          <|> memoizedLambdaExpr                          <|> memoizeExpr+                         <|> cambdaExpr+                         <|> macroExpr                          <|> patternFunctionExpr                          <|> letRecExpr                          <|> letExpr@@ -189,10 +192,16 @@                          <|> matcherDFSExpr                          <|> seqExpr                          <|> applyExpr+                         <|> cApplyExpr                          <|> algebraicDataMatcherExpr                          <|> generateArrayExpr-                         <|> arraySizeExpr-                         <|> arrayRefExpr)+                         <|> arrayBoundsExpr+                         <|> arrayRefExpr+                         <|> generateTensorExpr+                         <|> initTensorExpr+                         <|> tensorMapExpr+                         <|> tensorMap2Expr+                         )              <?> "expression")  varExpr :: Parser EgisonExpr@@ -215,13 +224,19 @@ arrayExpr = between lp rp $ ArrayExpr <$> sepEndBy expr whiteSpace   where     lp = P.lexeme lexer (string "[|")-    rp = P.lexeme lexer (string "|]")+    rp = string "|]" +tensorExpr :: Parser EgisonExpr+tensorExpr = between lp rp $ TensorExpr <$> expr <*> expr+  where+    lp = P.lexeme lexer (string "(|")+    rp = string "|)"+ hashExpr :: Parser EgisonExpr hashExpr = between lp rp $ HashExpr <$> sepEndBy pairExpr whiteSpace   where     lp = P.lexeme lexer (string "{|")-    rp = P.lexeme lexer (string "|}")+    rp = string "|}"     pairExpr :: Parser (EgisonExpr, EgisonExpr)     pairExpr = brackets $ (,) <$> expr <*> expr @@ -268,7 +283,7 @@ ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace  ppMatchClause :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])-ppMatchClause = brackets $ (,,) <$> pppattern <*> expr <*> pdMatchClauses+ppMatchClause = brackets $ (,,) <$> ppPattern <*> expr <*> pdMatchClauses  pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)] pdMatchClauses = braces $ sepEndBy pdMatchClause whiteSpace@@ -276,32 +291,36 @@ pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr) pdMatchClause = brackets $ (,) <$> pdPattern <*> expr -pppattern :: Parser PrimitivePatPattern-pppattern = ppWildCard-                 <|> pppatVar-                 <|> ppValuePat-                 <|> ppInductivePat-                 <?> "primitive-pattren-pattern"+ppPattern :: Parser PrimitivePatPattern+ppPattern = P.lexeme lexer (ppWildCard+                        <|> ppPatVar+                        <|> ppValuePat+                        <|> ppInductivePat+                        <?> "primitive-pattren-pattern")                         ppWildCard :: Parser PrimitivePatPattern ppWildCard = reservedOp "_" *> pure PPWildCard -pppatVar :: Parser PrimitivePatPattern-pppatVar = reservedOp "$" *> pure PPPatVar+ppPatVar :: Parser PrimitivePatPattern+ppPatVar = reservedOp "$" *> pure PPPatVar  ppValuePat :: Parser PrimitivePatPattern ppValuePat = string ",$" >> PPValuePat <$> ident  ppInductivePat :: Parser PrimitivePatPattern-ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy pppattern whiteSpace)+ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace)  pdPattern :: Parser PrimitiveDataPattern-pdPattern = reservedOp "_" *> pure PDWildCard+pdPattern = P.lexeme lexer $ pdPattern'++pdPattern' :: Parser PrimitiveDataPattern+pdPattern' = reservedOp "_" *> pure PDWildCard                     <|> (char '$' >> PDPatVar <$> ident)                     <|> braces ((PDConsPat <$> pdPattern <*> (char '@' *> pdPattern))                             <|> (PDSnocPat <$> (char '@' *> pdPattern) <*> pdPattern)                              <|> pure PDEmptyPat)                     <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern whiteSpace)+                    <|> brackets (PDTuplePat <$> sepEndBy pdPattern whiteSpace)                     <|> PDConstantPat <$> constantExpr                     <?> "primitive-data-pattern" @@ -323,6 +342,12 @@ memoizeBinding :: Parser (EgisonExpr, EgisonExpr, EgisonExpr) memoizeBinding = brackets $ (,,) <$> expr <*> expr <*> expr +cambdaExpr :: Parser EgisonExpr+cambdaExpr = keywordCambda >> CambdaExpr <$> varName <*> expr++macroExpr :: Parser EgisonExpr+macroExpr = keywordMacro >> MacroExpr <$> varNames <*> expr+ patternFunctionExpr :: Parser EgisonExpr patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern @@ -365,12 +390,12 @@ seqExpr :: Parser EgisonExpr seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr -contExpr :: Parser EgisonExpr-contExpr = reservedOp "..." >> pure ContExpr- recVarExpr :: Parser EgisonExpr recVarExpr = reservedOp "#" >> pure RecVarExpr +cApplyExpr :: Parser EgisonExpr+cApplyExpr = (keywordCApply >> CApplyExpr <$> expr <*> expr) + applyExpr :: Parser EgisonExpr applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr)               <|> applyExpr'@@ -418,22 +443,40 @@     inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace  generateArrayExpr :: Parser EgisonExpr-generateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> varNames <*> expr <*> expr+generateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> expr <*> arrayRange -arraySizeExpr :: Parser EgisonExpr-arraySizeExpr = keywordArraySize >> ArraySizeExpr <$> expr+arrayRange :: Parser (EgisonExpr, EgisonExpr)+arrayRange = brackets (do s <- expr+                          e <- expr+                          return (s, e)) +arrayBoundsExpr :: Parser EgisonExpr+arrayBoundsExpr = keywordArrayBounds >> ArrayBoundsExpr <$> expr+ arrayRefExpr :: Parser EgisonExpr arrayRefExpr = keywordArrayRef >> ArrayRefExpr <$> expr <*> expr +generateTensorExpr :: Parser EgisonExpr+generateTensorExpr = keywordGenerateTensor >> GenerateTensorExpr <$> expr <*> expr++initTensorExpr :: Parser EgisonExpr+initTensorExpr = keywordInitTensor >> InitTensorExpr <$> expr <*> expr <*> expr++tensorMapExpr :: Parser EgisonExpr+tensorMapExpr = keywordTensorMap >> TensorMapExpr <$> expr <*> expr++tensorMap2Expr :: Parser EgisonExpr+tensorMap2Expr = keywordTensorMap2 >> TensorMap2Expr <$> expr <*> expr <*> expr+ -- Patterns  pattern :: Parser EgisonPattern-pattern = do pattern <- pattern'-             option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> expr')+pattern = P.lexeme lexer (do pattern <- pattern'+                             option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> expr'))  pattern' :: Parser EgisonPattern pattern' = wildCard+            <|> contPat             <|> patVar             <|> varPat             <|> valuePat@@ -442,25 +485,31 @@             <|> notPat             <|> tuplePat             <|> inductivePat-            <|> contPat             <|> parens (andPat                     <|> orderedOrPat                     <|> orPat-                    <|> applyPat                     <|> loopPat-                    <|> letPat)+                    <|> letPat+                    <|> try dApplyPat+                    <|> try pApplyPat+                    ) +pattern'' :: Parser EgisonPattern+pattern'' = wildCard+            <|> patVar+            <|> valuePat+ wildCard :: Parser EgisonPattern wildCard = reservedOp "_" >> pure WildCard  patVar :: Parser EgisonPattern-patVar = P.lexeme lexer $ PatVar <$> varName+patVar = PatVar <$> varName  varPat :: Parser EgisonPattern varPat = VarPat <$> ident  valuePat :: Parser EgisonPattern-valuePat = reservedOp "," >> ValuePat <$> expr+valuePat = char ',' >> ValuePat <$> expr  regexPat :: Parser EgisonPattern regexPat = reservedOp "~" >> RegexPat <$> expr@@ -472,7 +521,7 @@ letPat = keywordLet >> LetPat <$> bindings <*> pattern  notPat :: Parser EgisonPattern-notPat = reservedOp "^" >> NotPat <$> pattern+notPat = reservedOp "!" >> NotPat <$> pattern  tuplePat :: Parser EgisonPattern tuplePat = brackets $ TuplePat <$> sepEndBy pattern whiteSpace@@ -481,7 +530,7 @@ inductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy pattern whiteSpace  contPat :: Parser EgisonPattern-contPat = reservedOp "..." >> pure ContPat+contPat = keywordCont >> pure ContPat  andPat :: Parser EgisonPattern andPat = reservedOp "&" >> AndPat <$> sepEndBy pattern whiteSpace@@ -492,9 +541,12 @@ orderedOrPat :: Parser EgisonPattern orderedOrPat = reservedOp "|*" >> OrderedOrPat <$> sepEndBy pattern whiteSpace -applyPat :: Parser EgisonPattern-applyPat = ApplyPat <$> expr <*> sepEndBy pattern whiteSpace +pApplyPat :: Parser EgisonPattern+pApplyPat = PApplyPat <$> expr <*> sepEndBy pattern whiteSpace  +dApplyPat :: Parser EgisonPattern+dApplyPat = DApplyPat <$> pattern'' <*> sepEndBy pattern whiteSpace + loopPat :: Parser EgisonPattern loopPat = keywordLoop >> LoopPat <$> varName <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern @@ -505,7 +557,7 @@                               return (LoopRange s e ep))                  <|> (do s <- expr                          ep <- option WildCard pattern-                         return (LoopRange s (ApplyExpr (VarExpr "from") (ApplyExpr (VarExpr "-") (TupleExpr [s, (NumberExpr (1, 0) (1, 0))]))) ep)))+                         return (LoopRange s (ApplyExpr (VarExpr "from") (ApplyExpr (VarExpr "-") (TupleExpr [s, (IntegerExpr 1)]))) ep)))  -- Constants @@ -514,7 +566,7 @@                  <|> stringExpr                  <|> boolExpr                  <|> try floatExpr-                 <|> try numberExpr+                 <|> try integerExpr                  <|> (keywordSomething *> pure SomethingExpr)                  <|> (keywordUndefined *> pure UndefinedExpr)                  <?> "constant"@@ -530,39 +582,21 @@  floatExpr :: Parser EgisonExpr floatExpr = do-  (x,y) <- P.lexeme lexer $ try (do x <- floatLiteral'-                                    y <- sign' <*> positiveFloatLiteral-                                    char 'i'-                                    return (x,y))-                            <|> try (do y <- floatLiteral'-                                        char 'i'-                                        return (0,y))-                            <|> try (do x <- floatLiteral'-                                        return (x,0))+  (x,y) <- try (do x <- floatLiteral'+                   y <- sign' <*> positiveFloatLiteral+                   char 'i'+                   return (x,y))+            <|> try (do y <- floatLiteral'+                        char 'i'+                        return (0,y))+            <|> try (do x <- floatLiteral'+                        return (x,0))   return $ FloatExpr x y -numberExpr :: Parser EgisonExpr-numberExpr = do-  (m,n) <- P.lexeme lexer $ try (do m <- gaussianIntegerLiteral-                                    char '/'-                                    n <- gaussianIntegerLiteral-                                    return (m,n))-                            <|> try (do m <- gaussianIntegerLiteral-                                        return (m,(1,0)))-  return $ NumberExpr m n--gaussianIntegerLiteral :: Parser (Integer, Integer)-gaussianIntegerLiteral = do-  (x,y) <- P.lexeme lexer $ try (do x <- integerLiteral'-                                    y <- sign' <*> positiveIntegerLiteral-                                    char 'i'-                                    return (x,y))-                            <|> try (do y <- integerLiteral'-                                        char 'i'-                                        return (0,y))-                            <|> try (do x <- integerLiteral'-                                        return (x,0))-  return (x,y)+integerExpr :: Parser EgisonExpr+integerExpr = do+  n <- integerLiteral'+  return $ IntegerExpr n  integerLiteral' :: Parser Integer integerLiteral' = sign <*> positiveIntegerLiteral@@ -599,10 +633,10 @@                 , P.reservedOpNames    = reservedOperators                 , P.nestedComments     = True                 , P.caseSensitive      = True }- where-  symbol1 = oneOf "+-*/="-  symbol2 = symbol1 <|> oneOf "'!?." +symbol1 = oneOf "+-*/=."+symbol2 = symbol1 <|> oneOf "'!?"+ lexer :: P.GenTokenParser String () Identity lexer = P.makeTokenParser egisonDef @@ -616,9 +650,12 @@   , "if"   , "seq"   , "apply"+  , "capply"   , "lambda"   , "memoized-lambda"   , "memoize"+  , "cambda"+  , "macro"   , "pattern-function"   , "letrec"   , "let"@@ -635,8 +672,12 @@   , "io"   , "algebraic-data-matcher"   , "generate-array"-  , "array-size"+  , "array-bounds"   , "array-ref"+  , "generate-tensor"+  , "init-tensor"+  , "tensor-map"+  , "tensor-map2"   , "something"   , "undefined"]   @@ -644,12 +685,13 @@ reservedOperators =    [ "$"   , "_"+  , "^"   , "&"   , "|"   , "|*"-  , "^"+  , "!"   , ","-  , "."+  , "~"   , "@"   , "..."] @@ -669,14 +711,18 @@ keywordElse                 = reserved "else" keywordSeq                  = reserved "seq" keywordApply                = reserved "apply"+keywordCApply               = reserved "capply" keywordLambda               = reserved "lambda" keywordMemoizedLambda       = reserved "memoized-lambda" keywordMemoize              = reserved "memoize"+keywordCambda               = reserved "cambda"+keywordMacro                = reserved "macro" keywordPatternFunction      = reserved "pattern-function" keywordLetRec               = reserved "letrec" keywordLet                  = reserved "let" keywordLetStar              = reserved "let*" keywordLoop                 = reserved "loop"+keywordCont                 = reserved "..." keywordMatchAll             = reserved "match-all" keywordMatchAllLambda       = reserved "match-all-lambda" keywordMatch                = reserved "match"@@ -694,8 +740,12 @@ keywordUndefined            = reserved "undefined" keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher" keywordGenerateArray        = reserved "generate-array"-keywordArraySize            = reserved "array-size"+keywordArrayBounds          = reserved "array-bounds" keywordArrayRef             = reserved "array-ref"+keywordGenerateTensor       = reserved "generate-tensor"+keywordInitTensor           = reserved "init-tensor"+keywordTensorMap            = reserved "tensor-map"+keywordTensorMap2           = reserved "tensor-map2"  sign :: Num a => Parser (a -> a) sign = (char '-' >> return negate)@@ -722,7 +772,7 @@ charLiteral = P.charLiteral lexer  boolLiteral :: Parser Bool-boolLiteral = P.lexeme lexer $ char '#' >> (char 't' *> pure True <|> char 'f' *> pure False)+boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False)  whiteSpace :: Parser () whiteSpace = P.whiteSpace lexer@@ -750,19 +800,21 @@  ident :: Parser String ident = P.identifier lexer-    <|> try ((:) <$> char '+' <*> ident)-    <|> try ((:) <$> char '-' <*> ident)-    <|> (P.lexeme lexer $ string "+")-    <|> (P.lexeme lexer $ string "-")  upperName :: Parser String-upperName = P.lexeme lexer $ (:) <$> upper <*> option "" ident+upperName = P.lexeme lexer $ upperName'++upperName' :: Parser String+upperName' = (:) <$> upper <*> option "" ident  where   upper :: Parser Char    upper = satisfy isUpper  lowerName :: Parser String-lowerName = P.lexeme lexer $ (:) <$> lower <*> option "" ident+lowerName = P.lexeme lexer $ lowerName'++lowerName' :: Parser String+lowerName' = (:) <$> lower <*> option "" ident  where   lower :: Parser Char    lower = satisfy isLower

@@ -13,6 +13,7 @@ import Control.Arrow import Control.Monad.Error import Control.Monad.Trans.Maybe+import Control.Applicative ((<$>), (<*>), (*>), (<*), pure)  import Data.IORef import Data.Ratio@@ -40,7 +41,7 @@  primitiveEnv :: IO Env primitiveEnv = do-  let ops = map (second PrimitiveFunc) (primitives ++ ioPrimitives)+  let ops = map (\(name, fn) -> (name, PrimitiveFunc name fn)) (primitives ++ ioPrimitives)   bindings <- forM (constants ++ ops) $ \(name, op) -> do     ref <- newIORef . WHNF $ Value op     return (name, ref)@@ -48,7 +49,7 @@  primitiveEnvNoIO :: IO Env primitiveEnvNoIO = do-  let ops = map (second PrimitiveFunc) primitives+  let ops = map (\(name, fn) -> (name, PrimitiveFunc name fn)) primitives   bindings <- forM (constants ++ ops) $ \(name, op) -> do     ref <- newIORef . WHNF $ Value op     return (name, ref)@@ -84,40 +85,40 @@     [val, val', val''] -> f val val' val'' >>= return . Value     _ -> throwError $ ArgumentsNumPrimitive 3 $ length args' -tupleToList :: WHNFData -> EgisonM [EgisonValue]-tupleToList whnf = do-  val <- evalWHNF whnf-  return $ tupleToList' val- where-  tupleToList' (Tuple vals) = vals-  tupleToList' val = [val]- -- -- Constants --  constants :: [(String, EgisonValue)]-constants = [ ("pi", Float 3.141592653589793 0) ]+constants = [+              ("f.pi", Float 3.141592653589793 0)+             ,("f.e" , Float 2.718281828459045 0)+              ]  -- -- Primitives --  primitives :: [(String, PrimitiveFunc)]-primitives = [ ("+", plus)-             , ("-", minus)-             , ("*", multiply)-             , ("/", divide)+primitives = [ ("b.+", plus)+             , ("b.-", minus)+             , ("b.*", multiply)+             , ("b./", divide)+             , ("b.+'", plus)+             , ("b.-'", minus)+             , ("b.*'", multiply)+             , ("b./'", divide)              , ("numerator", numerator')              , ("denominator", denominator')-             , ("real-part", realPart)-             , ("imaginary-part", imaginaryPart)-               +             , ("from-math-expr", fromScalarData)+             , ("to-math-expr", toScalarData)+             , ("to-math-expr'", toScalarData)+              , ("modulo",    integerBinaryOp mod)              , ("quotient",   integerBinaryOp quot)              , ("remainder", integerBinaryOp rem)-             , ("neg", rationalUnaryOp negate)              , ("abs", rationalUnaryOp abs)+             , ("neg", rationalUnaryOp negate)                              , ("eq?",  eq)              , ("lt?",  lt)@@ -129,23 +130,32 @@              , ("floor",    floatToIntegerOp floor)              , ("ceiling",  floatToIntegerOp ceiling)              , ("truncate", truncate')-               -             , ("sqrt", floatUnaryOp sqrt)-             , ("exp", floatUnaryOp exp)-             , ("log", floatUnaryOp log)-             , ("sin", floatUnaryOp sin)-             , ("cos", floatUnaryOp cos)-             , ("tan", floatUnaryOp tan)-             , ("asin", floatUnaryOp asin)-             , ("acos", floatUnaryOp acos)-             , ("atan", floatUnaryOp atan)-             , ("sinh", floatUnaryOp sinh)-             , ("cosh", floatUnaryOp cosh)-             , ("tanh", floatUnaryOp tanh)-             , ("asinh", floatUnaryOp asinh)-             , ("acosh", floatUnaryOp acosh)-             , ("atanh", floatUnaryOp atanh)+             , ("real-part", realPart)+             , ("imaginary-part", imaginaryPart)                +             , ("b.sqrt", floatUnaryOp sqrt)+             , ("b.sqrt'", floatUnaryOp sqrt)+             , ("b.exp", floatUnaryOp exp)+             , ("b.log", floatUnaryOp log)+             , ("b.sin", floatUnaryOp sin)+             , ("b.cos", floatUnaryOp cos)+             , ("b.tan", floatUnaryOp tan)+             , ("b.asin", floatUnaryOp asin)+             , ("b.acos", floatUnaryOp acos)+             , ("b.atan", floatUnaryOp atan)+             , ("b.sinh", floatUnaryOp sinh)+             , ("b.cosh", floatUnaryOp cosh)+             , ("b.tanh", floatUnaryOp tanh)+             , ("b.asinh", floatUnaryOp asinh)+             , ("b.acosh", floatUnaryOp acosh)+             , ("b.atanh", floatUnaryOp atanh)++             , ("b..", tensorProd)+             , ("b..'", tensorProd)+             , ("tensor-index", tensorIndex)+             , ("tensor-size", tensorSize)+             , ("tensor-to-list", tensorToList)+              , ("itof", integerToFloat)              , ("rtof", rationalToFloat)              , ("ctoi", charToInteger)@@ -171,16 +181,18 @@              , ("uncons", uncons')              , ("unsnoc", unsnoc') -             , ("bool?", isBool)-             , ("integer?", isInteger)-             , ("rational?", isRational)-             , ("number?", isNumber)-             , ("float?", isFloat)-             , ("char?", isChar)-             , ("string?", isString)-             , ("collection?", isCollection)-             , ("array?", isArray)-             , ("hash?", isHash)+             , ("bool?", isBool')+             , ("integer?", isInteger')+             , ("rational?", isRational')+             , ("number?", isNumber')+             , ("float?", isFloat')+             , ("char?", isChar')+             , ("string?", isString')+             , ("collection?", isCollection')+             , ("array?", isArray')+             , ("hash?", isHash')+             , ("tensor?", isTensor')+             , ("tensor-with-index?", isTensorWithIndex')               , ("assert", assert)              , ("assert-equal", assertEqual)@@ -190,14 +202,14 @@ rationalUnaryOp op = oneArg $ \val -> do   r <- fromEgison val   let r' =  op r-  return $ Number ((numerator r'), 0) ((denominator r'), 0)+  return $ toEgison r'    rationalBinaryOp :: (Rational -> Rational -> Rational) -> PrimitiveFunc rationalBinaryOp op = twoArgs $ \val val' -> do   r <- fromEgison val :: EgisonM Rational   r' <- fromEgison val' :: EgisonM Rational   let r'' = (op r r'')-  return $ Number ((numerator r''), 0) ((denominator r''), 0)+  return $ toEgison r''  rationalBinaryPred :: (Rational -> Rational -> Bool) -> PrimitiveFunc rationalBinaryPred pred = twoArgs $ \val val' -> do@@ -209,7 +221,7 @@ integerBinaryOp op = twoArgs $ \val val' -> do   i <- fromEgison val   i' <- fromEgison val'-  return $ Number ((op i i'), 0) (1, 0)+  return $ toEgison (op i i')  integerBinaryPred :: (Integer -> Integer -> Bool) -> PrimitiveFunc integerBinaryPred pred = twoArgs $ \val val' -> do@@ -221,15 +233,13 @@ floatUnaryOp op = oneArg $ \val -> do   case val of     (Float f 0) -> return $ Float (op f) 0-    n@(Number _ _) -> do-      r <- fromEgison n-      return $ Float (op (fromRational r)) 0+    _ -> throwError $ TypeMismatch "float" (Value val)  floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc floatBinaryOp op = twoArgs $ \val val' -> do-  f <- fromEgison val-  f' <- fromEgison val'-  return $ Float (op f f') 0+  case (val, val') of+    ((Float f 0), (Float f' 0)) -> return $ Float (op f f') 0+    _ -> throwError $ TypeMismatch "float" (Value val)  floatBinaryPred :: (Double -> Double -> Bool) -> PrimitiveFunc floatBinaryPred pred = twoArgs $ \val val' -> do@@ -240,71 +250,66 @@ -- -- Arith ---plus :: PrimitiveFunc-plus = twoArgs $ \val val' -> numberBinaryOp' val val'++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-  numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (addInteger' (mulInteger' x y') (mulInteger' x' y)) (mulInteger' y y')-  numberBinaryOp' (Float x y)  (Float x' y')  = return $ Float (x + x') (y + y')-  numberBinaryOp' val          (Float x' y')  = numberBinaryOp' (numberToFloat' val) (Float x' y')-  numberBinaryOp' (Float x y)  val'           = numberBinaryOp' (Float x y) (numberToFloat' val')-  numberBinaryOp' (Number _ _) val'           = throwError $ TypeMismatch "number" (Value val')-  numberBinaryOp' val          _              = throwError $ TypeMismatch "number" (Value val)+  numberUnaryOp' f@(Float _ _)  = return $ fOp f+  numberUnaryOp' (ScalarData m) = (return . ScalarData . mathNormalize') (mOp m)+  numberUnaryOp' val            = throwError $ TypeMismatch "number" (Value val) -minus :: PrimitiveFunc-minus = twoArgs $ \val val' -> numberBinaryOp' val 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'  where-  numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (subInteger' (mulInteger' x y') (mulInteger' x' y)) (mulInteger' y y')-  numberBinaryOp' (Float x y)  (Float x' y')  = return $ Float (x - x') (y - y')-  numberBinaryOp' val          (Float x' y')  = numberBinaryOp' (numberToFloat' val) (Float x' y')-  numberBinaryOp' (Float x y)  val'           = numberBinaryOp' (Float x y) (numberToFloat' val')-  numberBinaryOp' (Number _ _) val'           = throwError $ TypeMismatch "number" (Value val')-  numberBinaryOp' val          _              = throwError $ TypeMismatch "number" (Value val)+  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) +plus :: PrimitiveFunc+plus = numberBinaryOp mathPlus (\(Float x y) (Float x' y') -> Float (x + x')  (y + y'))++minus :: PrimitiveFunc+minus = numberBinaryOp (\m1 m2 -> mathPlus m1 (mathNegate m2)) (\(Float x y) (Float x' y') -> Float (x - x')  (y - y'))+ multiply :: PrimitiveFunc-multiply = twoArgs $ \val val' -> numberBinaryOp' val val'- where-  numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (mulInteger' x x') (mulInteger' y y')-  numberBinaryOp' (Float x y)  (Float x' y')  = return $ Float (x * x' - y * y')  (x * y' + x' * y) -  numberBinaryOp' val          (Float x' y')  = numberBinaryOp' (numberToFloat' val) (Float x' y')-  numberBinaryOp' (Float x y)  val'           = numberBinaryOp' (Float x y) (numberToFloat' val')-  numberBinaryOp' (Number _ _) val'           = throwError $ TypeMismatch "number" (Value val')-  numberBinaryOp' val          _              = throwError $ TypeMismatch "number" (Value val)+multiply = numberBinaryOp mathMult (\(Float x y) (Float x' y') -> Float (x * x' - y * y')  (x * y' + x' * y))  divide :: PrimitiveFunc-divide = twoArgs $ \val val' -> numberBinaryOp' val val'- where-  numberBinaryOp' (Number x y) (Number x' y') = return $ reduceFraction $ Number (mulInteger' x y') (mulInteger' y x')-  numberBinaryOp' (Float f 0)    (Float f' 0) = return $ Float (f / f') 0-  numberBinaryOp' val          (Float x' y')  = numberBinaryOp' (numberToFloat' val) (Float x' y')-  numberBinaryOp' (Float x y)  val'           = numberBinaryOp' (Float x y) (numberToFloat' val')-  numberBinaryOp' (Number _ _) val'           = throwError $ TypeMismatch "number" (Value val')-  numberBinaryOp' val          _              = throwError $ TypeMismatch "number" (Value val)+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')))  numerator' :: PrimitiveFunc numerator' =  oneArg $ numerator''  where-  numerator'' (Number (x,y) _) = return (Number (x,y) (1,0))+  numerator'' (ScalarData m) = return $ ScalarData (mathNumerator m)   numerator'' val = throwError $ TypeMismatch "rational" (Value val)  denominator' :: PrimitiveFunc denominator' =  oneArg $ denominator''  where-  denominator'' (Number _ (x,y)) = return (Number (x,y) (1,0))+  denominator'' (ScalarData m) = return $ ScalarData (mathDenominator m)   denominator'' val = throwError $ TypeMismatch "rational" (Value val) -realPart :: PrimitiveFunc-realPart =  oneArg $ realPart'+fromScalarData :: PrimitiveFunc+fromScalarData = oneArg $ fromScalarData'  where-  realPart' (Number (x,_) (x',0)) = return $ Number (x,0) (x',0)-  realPart' (Number _ _) =  throwError $ Default "real-part: denominator is not integer"-  realPart' val = throwError $ TypeMismatch "number" (Value val)+  fromScalarData' (ScalarData m) = return $ mathExprToEgison m+  fromScalarData' val = throwError $ TypeMismatch "number" (Value val) -imaginaryPart :: PrimitiveFunc-imaginaryPart =  oneArg $ imaginaryPart'+toScalarData :: PrimitiveFunc+toScalarData = oneArg $ toScalarData'  where-  imaginaryPart' (Number (_,y) (x',0)) = return $ Number (y,0) (x',0)-  imaginaryPart' (Number _ _) =  throwError $ Default "imaginary-part: denominator is not integer"-  imaginaryPart' val = throwError $ TypeMismatch "number" (Value val)+  toScalarData' val = egisonToScalarData val >>= return . ScalarData . mathNormalize'  -- -- Pred@@ -316,63 +321,111 @@ lt :: PrimitiveFunc lt = twoArgs $ \val val' -> numberBinaryPred' val val'  where-  numberBinaryPred' m@(Number _ _) n@(Number _ _) = do+  numberBinaryPred' 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' (Number _ _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)   numberBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)   numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)    lte :: PrimitiveFunc lte = twoArgs $ \val val' -> numberBinaryPred' val val'  where-  numberBinaryPred' m@(Number _ _) n@(Number _ _) = do+  numberBinaryPred' 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' (Number _ _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)   numberBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)   numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)    gt :: PrimitiveFunc gt = twoArgs $ \val val' -> numberBinaryPred' val val'  where-  numberBinaryPred' m@(Number _ _) n@(Number _ _) = do+  numberBinaryPred' 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' (Number _ _) val           = throwError $ TypeMismatch "number" (Value val)+  numberBinaryPred' (ScalarData _) val           = throwError $ TypeMismatch "number" (Value val)   numberBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)   numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)    gte :: PrimitiveFunc gte = twoArgs $ \val val' -> numberBinaryPred' val val'  where-  numberBinaryPred' m@(Number _ _) n@(Number _ _) = do+  numberBinaryPred' 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' (Number _ _) val           = throwError $ TypeMismatch "number" (Value val)-  numberBinaryPred' (Float _ _)  val           = throwError $ TypeMismatch "float" (Value val)-  numberBinaryPred' val          _             = throwError $ TypeMismatch "number" (Value val)+  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)    truncate' :: PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val  where-  numberUnaryOp' (Number (x,0) (x',0)) = return $ Number ((quot x x'), 0) (1,0)-  numberUnaryOp' (Float x y)           = return $ Number ((truncate x), (truncate y)) (1,0)+  numberUnaryOp' (ScalarData (Div (Plus []) _)) = return $ toEgison (0 :: Integer)+  numberUnaryOp' (ScalarData (Div (Plus [(Term x [])]) (Plus [(Term y [])]))) = return $ toEgison (quot x y)+  numberUnaryOp' (Float x _)           = return $ toEgison ((truncate x) :: Integer)   numberUnaryOp' val                   = throwError $ TypeMismatch "ratinal or float" (Value val) +realPart :: PrimitiveFunc+realPart =  oneArg $ realPart'+ where+  realPart' (Float x y) = return $ Float x 0+  realPart' val = throwError $ TypeMismatch "float" (Value val)++imaginaryPart :: PrimitiveFunc+imaginaryPart =  oneArg $ imaginaryPart'+ where+  imaginaryPart' (Float _ y) = return $ Float y 0+  imaginaryPart' val = throwError $ TypeMismatch "float" (Value val)+ --+-- 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'+ where+  tensorSize' (TensorData (TData (Tensor ns _) _)) = return . Collection . Sq.fromList $ map toEgison ns+  tensorSize' val = throwError $ TypeMismatch "tensor data" (Value val)++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)++-- -- Transform -- numberToFloat' :: EgisonValue -> EgisonValue-numberToFloat' (Number (x,y) (d,0)) = Float (fromRational (x % d)) (fromRational (y % d))+numberToFloat' (ScalarData (Div (Plus []) _)) = Float 0 0+numberToFloat' (ScalarData (Div (Plus [(Term x [])]) (Plus [(Term y [])]))) = Float (fromRational (x % y)) 0  integerToFloat :: PrimitiveFunc integerToFloat = rationalToFloat@@ -380,25 +433,30 @@ rationalToFloat :: PrimitiveFunc rationalToFloat = oneArg $ \val ->   case val of-    Number (x,y) (d,0) -> return $ numberToFloat' val-    _ -> throwError $ TypeMismatch "integer of rational number" (Value val)+    (ScalarData (Div (Plus []) _)) -> return $ numberToFloat' val+    (ScalarData (Div (Plus [(Term _ [])]) (Plus [(Term _ [])]))) -> return $ numberToFloat' val+    _ -> throwError $ TypeMismatch "integer or rational number" (Value val)  charToInteger :: PrimitiveFunc charToInteger = oneArg $ \val -> do   case val of-    Char c -> return $ Number ((fromIntegral $ ord c), 0) (1,0)+    Char c -> do+      let i = fromIntegral $ ord c :: Integer+      return $ toEgison i     _ -> throwError $ TypeMismatch "character" (Value val)  integerToChar :: PrimitiveFunc integerToChar = oneArg $ \val -> do   case val of-    (Number (x,0) (1,0)) -> return $ Char $ chr $ fromIntegral x+    (ScalarData _) -> do+       i <- fromEgison val :: EgisonM Integer+       return $ Char $ chr $ fromIntegral i     _ -> throwError $ TypeMismatch "integer" (Value val)  floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc floatToIntegerOp op = oneArg $ \val -> do   f <- fromEgison val-  return $ Number ((op f), 0) (1,0)+  return $ toEgison (op f)  -- -- String@@ -425,7 +483,7 @@ lengthString :: PrimitiveFunc lengthString = oneArg $ \val -> do   case val of-    String str -> return . (\x -> Number (x,0) (1,0)) . toInteger $ T.length str+    String str -> return . (\x -> toEgison x) . toInteger $ T.length str     _ -> throwError $ TypeMismatch "string" (Value val)  appendString :: PrimitiveFunc@@ -521,57 +579,6 @@     Just (racObjRef, rdcObjRef) -> return $ Intermediate $ ITuple [racObjRef, rdcObjRef]     Nothing -> throwError $ Default $ "cannot unsnoc collection" --- Typing--isBool :: PrimitiveFunc-isBool (Value (Bool _)) = return $ Value $ Bool True-isBool _ = return $ Value $ Bool False--isInteger :: PrimitiveFunc-isInteger (Value (Number (_,0) (1,0))) = return $ Value $ Bool True-isInteger _ = return $ Value $ Bool False--isRational :: PrimitiveFunc-isRational (Value (Number (_, 0) (_, 0))) = return $ Value $ Bool True-isRational _ = return $ Value $ Bool False--isNumber :: PrimitiveFunc-isNumber (Value (Number _ _)) = return $ Value $ Bool True-isNumber _ = return $ Value $ Bool False--isFloat :: PrimitiveFunc-isFloat (Value (Float _ 0)) = return $ Value $ Bool True-isFloat _ = return $ Value $ Bool False--isComplex :: PrimitiveFunc-isComplex (Value (Float _ _)) = return $ Value $ Bool True-isComplex _ = return $ Value $ Bool False--isChar :: PrimitiveFunc-isChar (Value (Char _)) = return $ Value $ Bool True-isChar _ = return $ Value $ Bool False--isString :: PrimitiveFunc-isString (Value (String _)) = return $ Value $ Bool True-isString _ = return $ Value $ Bool False--isCollection :: PrimitiveFunc-isCollection (Value (Collection _)) = return $ Value $ Bool True-isCollection (Intermediate (ICollection _)) = return $ Value $ Bool True-isCollection _ = return $ Value $ Bool False--isArray :: PrimitiveFunc-isArray (Value (Array _)) = return $ Value $ Bool True-isArray (Intermediate (IArray _)) = return $ Value $ Bool True-isArray _ = return $ Value $ Bool False--isHash :: PrimitiveFunc-isHash (Value (IntHash _)) = return $ Value $ Bool True-isHash (Value (StrHash _)) = return $ Value $ Bool True-isHash (Intermediate (IIntHash _)) = return $ Value $ Bool True-isHash (Intermediate (IStrHash _)) = return $ Value $ Bool True-isHash _ = return $ Value $ Bool False- -- Test  assert ::  PrimitiveFunc@@ -704,10 +711,10 @@  randRange :: PrimitiveFunc randRange = twoArgs $ \val val' -> do-  i <- fromEgison val-  i' <- fromEgison val'+  i <- fromEgison val :: EgisonM Integer+  i' <- fromEgison val' :: EgisonM Integer   n <- liftIO $ getStdRandom $ randomR (i, i')-  return $ makeIO $ return $ Number (n,0) (1,0)+  return $ makeIO $ return $ toEgison n   {-- -- for 'egison-sqlite' sqlite :: PrimitiveFunc

@@ -24,17 +24,44 @@     , PrimitiveDataPattern (..)     -- * Egison values     , EgisonValue (..)+    , ScalarData (..)+    , PolyExpr (..)+    , TermExpr (..)+    , SymbolExpr (..)+    , TensorData (..)+    , Tensor (..)+    , scalarToUnitTensor+    , scalarToTensor+    , tMap+    , tMap2+    , tCheckIndex+    , tContract+    , tref+    , tref'+    , tSize+    , tToList+    , tIndex+    , makeTensor+    , tensorIndices+    , symbolScalarData+    , mathExprToEgison+    , egisonToScalarData+    , mathNormalize'+    , mathFold+    , mathSymbolFold+    , mathTermFold+    , mathRemoveZero+    , mathReduceFraction+    , mathReduceSymbolFraction+    , mathPlus+    , mathMult+    , mathNegate+    , mathNumerator+    , mathDenominator     , Matcher (..)     , PrimitiveFunc (..)     , EgisonData (..)     , showTSV-    , addInteger-    , subInteger-    , mulInteger-    , addInteger'-    , subInteger'-    , mulInteger'-    , reduceFraction     -- * Internal data     , Object (..)     , ObjectRef (..)@@ -81,6 +108,27 @@     , mconcat     , mmap     , mfor+    -- * Typing+    , isBool+    , isInteger+    , isRational+    , isSymbol+    , isNumber+    , isTensor+    , isTensorWithIndex+    , isBool'+    , isInteger'+    , isRational'+    , isNumber'+    , isFloat'+    , isComplex'+    , isTensor'+    , isTensorWithIndex'+    , isChar'+    , isString'+    , isCollection'+    , isArray'+    , isHash'     ) where  import Prelude hiding (foldr, mappend, mconcat)@@ -97,6 +145,7 @@ import Control.Monad.Trans.Maybe  import Data.Monoid (Monoid)+import qualified Data.HashMap.Lazy as HL import qualified Data.Array as Array import qualified Data.Sequence as Sq import Data.Sequence (Seq)@@ -105,7 +154,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List (intercalate)+import Data.List (intercalate, sort, sortBy) import Data.Text (Text) import qualified Data.Text as T @@ -126,25 +175,29 @@     -- temporary : we will replace load to import and export   | LoadFile String   | Load String- deriving (Show)+ deriving (Show, Eq)  data EgisonExpr =     CharExpr Char   | StringExpr Text   | BoolExpr Bool-  | NumberExpr (Integer, Integer) (Integer, Integer)+  | IntegerExpr Integer   | FloatExpr Double Double   | VarExpr String   | IndexedExpr EgisonExpr [EgisonExpr]+  | PowerExpr EgisonExpr EgisonExpr   | InductiveDataExpr String [EgisonExpr]   | TupleExpr [EgisonExpr]   | CollectionExpr [InnerExpr]   | ArrayExpr [EgisonExpr]   | HashExpr [(EgisonExpr, EgisonExpr)]+  | TensorExpr EgisonExpr EgisonExpr    | LambdaExpr [String] EgisonExpr   | MemoizedLambdaExpr [String] EgisonExpr   | MemoizeExpr [(EgisonExpr, EgisonExpr, EgisonExpr)] EgisonExpr+  | CambdaExpr String EgisonExpr+  | MacroExpr [String] EgisonExpr   | PatternFunctionExpr [String] EgisonPattern      | IfExpr EgisonExpr EgisonExpr EgisonExpr@@ -164,30 +217,35 @@    | MatcherBFSExpr MatcherInfo   | MatcherDFSExpr MatcherInfo+  | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]      | DoExpr [BindingExpr] EgisonExpr   | IoExpr EgisonExpr        | SeqExpr EgisonExpr EgisonExpr-  | ContExpr   | ApplyExpr EgisonExpr EgisonExpr+  | CApplyExpr EgisonExpr EgisonExpr   | PartialExpr Integer EgisonExpr   | PartialVarExpr Integer   | RecVarExpr -  | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]-  | GenerateArrayExpr [String] EgisonExpr EgisonExpr-  | ArraySizeExpr EgisonExpr+  | GenerateArrayExpr EgisonExpr (EgisonExpr, EgisonExpr)+  | ArrayBoundsExpr EgisonExpr   | ArrayRefExpr EgisonExpr EgisonExpr +  | GenerateTensorExpr EgisonExpr EgisonExpr+  | InitTensorExpr EgisonExpr EgisonExpr EgisonExpr+  | TensorMapExpr EgisonExpr EgisonExpr+  | TensorMap2Expr EgisonExpr EgisonExpr EgisonExpr+   | SomethingExpr   | UndefinedExpr- deriving (Show)+ deriving (Show, Eq)  data InnerExpr =     ElementExpr EgisonExpr   | SubCollectionExpr EgisonExpr- deriving (Show)+ deriving (Show, Eq)  type BindingExpr = ([String], EgisonExpr) type MatchClause = (EgisonPattern, EgisonExpr)@@ -209,29 +267,31 @@   | InductivePat String [EgisonPattern]   | LoopPat String LoopRange EgisonPattern EgisonPattern   | ContPat-  | ApplyPat EgisonExpr [EgisonPattern]+  | PApplyPat EgisonExpr [EgisonPattern]+  | DApplyPat EgisonPattern [EgisonPattern]   | VarPat String- deriving (Show)+ deriving (Show, Eq)  data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern- deriving (Show)+ deriving (Show, Eq)  data PrimitivePatPattern =     PPWildCard   | PPPatVar   | PPValuePat String   | PPInductivePat String [PrimitivePatPattern]- deriving (Show)+ deriving (Show, Eq)  data PrimitiveDataPattern =     PDWildCard   | PDPatVar String   | PDInductivePat String [PrimitiveDataPattern]+  | PDTuplePat [PrimitiveDataPattern]   | PDEmptyPat   | PDConsPat PrimitiveDataPattern PrimitiveDataPattern   | PDSnocPat PrimitiveDataPattern PrimitiveDataPattern   | PDConstantPat EgisonExpr- deriving (Show)+ deriving (Show, Eq)  -- -- Values@@ -242,7 +302,8 @@   | Char Char   | String Text   | Bool Bool-  | Number (Integer, Integer) (Integer, Integer)+  | ScalarData ScalarData+  | TensorData TensorData   | Float Double Double   | InductiveData String [EgisonValue]   | Tuple [EgisonValue]@@ -252,16 +313,385 @@   | CharHash (HashMap Char EgisonValue)   | StrHash (HashMap Text EgisonValue)   | UserMatcher Env PMMode MatcherInfo-  | Func Env [String] EgisonExpr-  | MemoizedFunc ObjectRef (IORef (HashMap [Integer] ObjectRef)) Env [String] EgisonExpr+  | Func (Maybe String) Env [String] EgisonExpr+  | CFunc (Maybe String) Env String EgisonExpr+  | MemoizedFunc (Maybe String) ObjectRef (IORef (HashMap [Integer] ObjectRef)) Env [String] EgisonExpr+  | Macro [String] EgisonExpr   | PatternFunc Env [String] EgisonPattern-  | PrimitiveFunc PrimitiveFunc+  | PrimitiveFunc String PrimitiveFunc   | IOFunc (EgisonM WHNFData)   | Port Handle   | Something   | Undefined   | EOF +--+-- Scalars+--++data ScalarData =+    Div PolyExpr PolyExpr+ deriving (Eq)++data PolyExpr =+    Plus [TermExpr]+ deriving (Eq)++data TermExpr =+    Term Integer [(SymbolExpr, Integer)]+ deriving (Eq)++data SymbolExpr =+    Symbol String [Integer]+  | Apply EgisonValue [ScalarData]+ deriving (Eq)+++symbolScalarData :: String -> [Integer] -> EgisonValue+symbolScalarData name js = (ScalarData (Div (Plus [(Term 1 [(Symbol name js, 1)])]) (Plus [(Term 1 [])])))++mathExprToEgison :: ScalarData -> EgisonValue+mathExprToEgison (Div p1 p2) = InductiveData "Div" [(polyExprToEgison p1), (polyExprToEgison p2)]++polyExprToEgison :: PolyExpr -> EgisonValue+polyExprToEgison (Plus ts) = InductiveData "Plus" [Collection (Sq.fromList (map termExprToEgison ts))]++termExprToEgison :: TermExpr -> EgisonValue+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 (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n]++egisonToScalarData :: EgisonValue -> EgisonM ScalarData+egisonToScalarData (InductiveData "Div" [p1, p2]) = Div <$> egisonToPolyExpr p1 <*> egisonToPolyExpr p2+egisonToScalarData p1@(InductiveData "Plus" _) = Div <$> egisonToPolyExpr p1 <*> (return (Plus [(Term 1 [])]))+egisonToScalarData t1@(InductiveData "Term" _) = do+  t1' <- egisonToTermExpr t1+  return $ Div (Plus [t1']) (Plus [(Term 1 [])])+egisonToScalarData s1@(InductiveData "Symbol" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 ::Integer)])+  return $ Div (Plus [(Term 1 [s1'])]) (Plus [(Term 1 [])])+egisonToScalarData s1@(InductiveData "Apply" _) = 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+egisonToPolyExpr (InductiveData "Plus" [Collection ts]) = Plus <$> mapM egisonToTermExpr (toList ts)+egisonToPolyExpr val = liftError $ throwError $ TypeMismatch "math poly expression" (Value val)++egisonToTermExpr :: EgisonValue -> EgisonM TermExpr+egisonToTermExpr (InductiveData "Term" [n, Collection ts]) = Term <$> fromEgison n <*> mapM egisonToSymbolExpr (toList ts)+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+  n' <- fromEgison n+  return (Symbol (T.unpack x') 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 val = liftError $ throwError $ TypeMismatch "math symbol expression" (Value val)++mathNormalize' :: ScalarData -> ScalarData+mathNormalize' mExpr = mathReduceSymbolFraction (mathReduceFraction (mathRemoveZero (mathFold (mathRemoveZeroSymbol mExpr))))++mathRemoveZeroSymbol :: ScalarData -> ScalarData+mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) =+  let p x = case x of+              (_, 0) -> False+              _ -> True in+  let ts1' = map (\(Term a xs) -> Term a (filter p xs)) ts1 in+  let ts2' = map (\(Term a xs) -> Term a (filter p xs)) ts2 in+    Div (Plus ts1') (Plus ts2')++mathRemoveZero :: ScalarData -> ScalarData+mathRemoveZero (Div (Plus ts1) (Plus ts2)) =+  let ts1' = filter (\(Term a _) -> a /= 0) ts1 in+  let ts2' = filter (\(Term a _) -> a /= 0) ts2 in+    case ts1' of+      [] -> Div (Plus []) (Plus [Term 1 []])+      _ -> Div (Plus ts1') (Plus ts2')++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)))++mathSymbolFold :: ScalarData -> ScalarData+mathSymbolFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (map f ts1)) (Plus (map f ts2))+ where+  f :: TermExpr -> TermExpr+  f (Term a xs) = Term a (g [] xs)+  g :: [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)]+  g ret [] = ret+  g ret ((x, n):xs) =+    if (any (p (x, n)) ret)+      then g (map (h (x, n)) ret) xs+      else g (ret ++ [(x, n)]) xs+  p :: (SymbolExpr, Integer) -> (SymbolExpr, Integer) -> Bool+  p (x, _) (y, _) = x == y+  h :: (SymbolExpr, Integer) -> (SymbolExpr, Integer) -> (SymbolExpr, Integer)+  h (x, n) (y, m) = if x == y+                     then (y, m + n)+                     else (y, m)++mathTermFold :: ScalarData -> ScalarData+mathTermFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (f ts1)) (Plus (f ts2))+ where+  f :: [TermExpr] -> [TermExpr]+  f ts = f' [] ts+  f' :: [TermExpr] -> [TermExpr] -> [TermExpr]+  f' ret [] = ret+  f' ret ((Term a xs):ts) =+    if any (\(Term _ ys) -> (p xs ys)) ret+      then f' (map (g (Term a xs)) ret) ts+      else f' (ret ++ [(Term a xs)]) ts+  g :: TermExpr -> TermExpr -> TermExpr+  g (Term a xs) (Term b ys) = if p xs ys+                                then (Term (a + b) ys)+                                else Term b ys+  p :: [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> Bool+  p [] [] = True+  p [] _ = False+  p ((x, n):xs) ys =+    let (b, ys') = q (x, n) [] ys in+      if b +        then p xs ys'+        else False+  q :: (SymbolExpr, Integer) -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Bool, [(SymbolExpr, Integer)])+  q _ _ [] = (False, [])+  q (x, n) ret ((y, m):ys) = if (x == y) && (n == m)+                               then (True, (ret ++ ys))+                               else q (x, n) (ret ++ [(y, m)]) ys++--+--  Arithmetic operations+--++mathPlus :: ScalarData -> ScalarData -> ScalarData+mathPlus (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathPlusPoly (mathMultPoly m1 n2) (mathMultPoly m2 n1)) (mathMultPoly n1 n2)++mathPlusPoly :: PolyExpr -> PolyExpr -> PolyExpr+mathPlusPoly (Plus ts1) (Plus ts2) = Plus (ts1 ++ ts2)++mathMult :: ScalarData -> ScalarData -> ScalarData+mathMult (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathMultPoly m1 m2) (mathMultPoly n1 n2)++mathMultPoly :: PolyExpr -> PolyExpr -> PolyExpr+mathMultPoly (Plus []) (Plus _) = Plus []+mathMultPoly (Plus _) (Plus []) = Plus []+mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> (Plus (map (\(Term b ys) -> (Term (a * b) (xs ++ ys))) ts2))) ts1)++mathNegate :: ScalarData -> ScalarData+mathNegate (Div m n) = Div (mathNegate' m) n++mathNegate' :: PolyExpr -> PolyExpr+mathNegate' (Plus ts) = Plus (map (\(Term a xs) -> (Term (negate a) xs)) ts)++mathNumerator :: ScalarData -> ScalarData+mathNumerator (Div m _) = Div m (Plus [(Term 1 [])])++mathDenominator :: ScalarData -> ScalarData+mathDenominator (Div _ n) = Div n (Plus [(Term 1 [])])++--+-- Tensors+--++data TensorData =+    TData (Tensor ScalarData) (Maybe [ScalarData])+ deriving (Eq)++data Tensor a = Tensor [Integer] [a]+ deriving (Eq)++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++scalarToTensor :: [Integer] -> ScalarData -> (Maybe [ScalarData]) -> TensorData+scalarToTensor ns x js = makeTensor ns (map (\ms -> x) (tensorIndices ns)) js++makeTensor :: [Integer] -> [ScalarData] -> (Maybe [ScalarData]) -> TensorData+makeTensor ns xs js = TData (Tensor ns xs) js++tensorIndices :: [Integer] -> [[Integer]]+tensorIndices [] = [[]]+tensorIndices (n:ns) = concat (map (\i -> (map (\is -> i:is) (tensorIndices ns))) [1..n])++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++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++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++transIndex :: [ScalarData] -> [ScalarData] -> [Integer] -> EgisonM [Integer]+transIndex [] [] [] = return []+transIndex (j1:js1) js2 is = do+  let (hjs2, tjs2) = break (\j2 -> j1 == j2) js2+  if tjs2 == []+    then 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)+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+ 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++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))++tref' :: [Integer] -> (Tensor a) -> a+tref' ms (Tensor ns xs) = tref'' ms ns xs+ 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++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+ 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+                 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++tToList :: (Tensor a) -> [a]+tToList (Tensor _ xs) = xs++tIndex :: TensorData -> Maybe [ScalarData]+tIndex (TData (Tensor _ _) js) = js+ type Matcher = EgisonValue  type PrimitiveFunc = WHNFData -> EgisonM WHNFData@@ -271,8 +701,8 @@   show (String str) = "\"" ++ T.unpack str ++ "\""   show (Bool True) = "#t"   show (Bool False) = "#f"-  show (Number (x,y) (1,0)) = showComplex x y-  show (Number (x,y) (x',y')) = showComplex x y ++ "/" ++ showComplex x' y'+  show (ScalarData mExpr) = show mExpr+  show (TensorData tExpr) = show tExpr   show (Float x y) = showComplexFloat x y   show (InductiveData name []) = "<" ++ name ++ ">"   show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">"@@ -286,10 +716,15 @@   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 _ names _) = "(lambda [" ++ unwords names ++ "] ...)"-  show (MemoizedFunc _ _ _ names _) = "(memoized-lambda [" ++ unwords names ++ "] ...)"+  show (Func Nothing _ names _) = "(lambda [" ++ unwords names ++ "] ...)"+  show (Func (Just name) _ _ _) = name+  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 (Macro names _) = "(macro [" ++ unwords names ++ "] ...)"   show (PatternFunc _ _ _) = "#<pattern-function>"-  show (PrimitiveFunc _) = "#<primitive-function>"+  show (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"   show (IOFunc _) = "#<io-function>"   show (Port _) = "#<port>"   show Something = "something"@@ -297,23 +732,29 @@   show World = "#<world>"   show EOF = "#<eof>" -addInteger :: EgisonValue -> EgisonValue -> EgisonValue-addInteger (Number (x,y) (1,0)) (Number (x',y') (1,0)) = Number ((x+x'),(y+y')) (1,0)--subInteger :: EgisonValue -> EgisonValue -> EgisonValue-subInteger (Number (x,y) (1,0)) (Number (x',y') (1,0)) = Number ((x-x'),(y-y')) (1,0)+instance Show ScalarData where+  show (Div p1 (Plus [(Term 1 [])])) = show p1+  show (Div p1 p2) = "(/ " ++ show p1 ++ " " ++ show p2 ++ ")" -mulInteger :: EgisonValue -> EgisonValue -> EgisonValue-mulInteger (Number (x,y) (1,0)) (Number (x',y') (1,0)) = Number ((x*x'-y*y'),(x*y'+x'*y)) (1,0)+instance Show PolyExpr where+  show (Plus []) = "0"+  show (Plus [t]) = show t+  show (Plus ts) = "(+ " ++ unwords (map show ts)  ++ ")" -addInteger' :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer)-addInteger' (x,y) (x',y') = ((x+x'),(y+y'))+instance Show TermExpr where+  show (Term a []) = show a+  show (Term 1 [x]) = showPoweredSymbol x+  show (Term 1 xs) = "(* " ++ unwords (map showPoweredSymbol xs) ++ ")"+  show (Term a xs) = "(* " ++ show a ++ " " ++ unwords (map showPoweredSymbol xs) ++ ")" -subInteger' :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer)-subInteger' (x,y) (x',y') = ((x-x'),(y-y'))+showPoweredSymbol :: (SymbolExpr, Integer) -> String+showPoweredSymbol (x, 1) = show x+showPoweredSymbol (x, n) = show x ++ "^" ++ show n -mulInteger' :: (Integer, Integer) -> (Integer, Integer) -> (Integer, Integer)-mulInteger' (x,y) (x',y') = ((x*x'-y*y'),(x*y'+x'*y))+instance Show SymbolExpr where+  show (Symbol s []) = s+  show (Symbol s js) = s ++ unwords' (map show js)+  show (Apply fn mExprs) = "(" ++ show fn ++ " " ++ unwords (map show mExprs) ++ ")"  showComplex :: (Num a, Eq a, Ord a, Show a) => a -> a -> String showComplex x 0 = show x@@ -323,20 +764,19 @@ 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")+showComplexFloat x y = showFFloat Nothing x "" ++ if y > 0 then "+" else "" ++ showFFloat Nothing y "i" -reduceFraction :: EgisonValue -> EgisonValue-reduceFraction (Number (x,y) (x',y'))-    | x' < 0  = let m = negate (foldl gcd x [y, x', y']) in-                  Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m)-    | x' > 0  = let m = foldl gcd x [y, x', y'] in-                  Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m)-    | x' == 0 && y' < 0  = let m = negate (foldl gcd x [y, x', y']) in-                             Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m)-    | x' == 0 && y' > 0  = let m = foldl gcd x [y, x', y'] in-                             Number (x `quot` m, y `quot` m) (x' `quot` m, y' `quot` m)-    | x' == 0 && y' == 0 = Number (1,0) (0,0)+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) ++ "} |)"++ showTSV :: EgisonValue -> String showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map showTSV vals) showTSV (Collection vals) = intercalate "\t" (map showTSV (toList vals))@@ -346,7 +786,8 @@  (Char c) == (Char c') = c == c'  (String str) == (String str') = str == str'  (Bool b) == (Bool b') = b == b'- (Number (x1,y1) (x1',y1')) == (Number (x2,y2) (x2',y2')) = (x1 == x2) && (y1 == y2) && (x1' == x2') && (y1' == y2')+ (ScalarData x) == (ScalarData y) = (x == y)+ (TensorData x) == (TensorData y) = (x == y)  (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'@@ -355,6 +796,13 @@  (IntHash vals) == (IntHash vals') = vals == vals'  (CharHash vals) == (CharHash vals') = vals == vals'  (StrHash vals) == (StrHash vals') = vals == vals'+ (PrimitiveFunc name1 _) == (PrimitiveFunc name2 _) = name1 == name2+ -- Temporary: searching a better solution+ (Func Nothing _ xs1 expr1) == (Func Nothing _ xs2 expr2) = (xs1 == xs2) && (expr1 == expr2)+ (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _) = name1 == name2+ (CFunc Nothing _ x1 expr1) == (CFunc Nothing _ x2 expr2) = (x1 == x2) && (expr1 == expr2)+ (CFunc (Just name1) _ _ _) == (CFunc (Just name2) _ _ _) = name1 == name2+ (Macro xs1 expr1) == (Macro xs2 expr2) = (xs1 == xs2) && (expr1 == expr2)  _ == _ = False  --@@ -377,11 +825,12 @@   fromEgison = liftError . fromBoolValue  instance EgisonData Integer where-  toEgison i = Number (i, 0) (1, 0)+  toEgison 0 = ScalarData $ mathNormalize' (Div (Plus []) (Plus [(Term 1 [])]))+  toEgison i = ScalarData $ mathNormalize' (Div (Plus [(Term i [])]) (Plus [(Term 1 [])]))   fromEgison = liftError . fromIntegerValue  instance EgisonData Rational where-  toEgison r = Number ((numerator r), 0) ((denominator r), 0)+  toEgison r = ScalarData $ mathNormalize' (Div (Plus [(Term (numerator r) [])]) (Plus [(Term (denominator r) [])]))   fromEgison = liftError . fromRationalValue  instance EgisonData Double where@@ -439,11 +888,13 @@ fromBoolValue val = throwError $ TypeMismatch "bool" (Value val)  fromIntegerValue :: EgisonValue -> Either EgisonError Integer-fromIntegerValue (Number (x, 0) (1, 0)) = return x+fromIntegerValue (ScalarData (Div (Plus []) (Plus [(Term 1 [])]))) = return 0+fromIntegerValue (ScalarData (Div (Plus [(Term x [])]) (Plus [(Term 1 [])]))) = return x fromIntegerValue val = throwError $ TypeMismatch "integer" (Value val)  fromRationalValue :: EgisonValue -> Either EgisonError Rational-fromRationalValue (Number (x, 0) (y, 0)) = return (x % y)+fromRationalValue (ScalarData (Div (Plus []) _)) = return 0+fromRationalValue (ScalarData (Div (Plus [(Term x [])]) (Plus [(Term y [])]))) = return (x % y) fromRationalValue val = throwError $ TypeMismatch "rational" (Value val)  fromFloatValue :: EgisonValue -> Either EgisonError Double@@ -519,9 +970,6 @@ instance EgisonWHNF Integer where   fromWHNF = liftError . fromIntegerWHNF   -instance EgisonWHNF Rational where-  fromWHNF = liftError . fromRationalWHNF-   instance EgisonWHNF Double where   fromWHNF = liftError . fromFloatWHNF   @@ -541,13 +989,10 @@ fromBoolWHNF whnf = throwError $ TypeMismatch "bool" whnf  fromIntegerWHNF :: WHNFData -> Either EgisonError Integer-fromIntegerWHNF (Value (Number (x, 0) (1, 0))) = return x+fromIntegerWHNF (Value (ScalarData (Div (Plus []) (Plus [(Term 1 [])])))) = return 0+fromIntegerWHNF (Value (ScalarData (Div (Plus [(Term x [])]) (Plus [(Term 1 [])])))) = return x fromIntegerWHNF whnf = throwError $ TypeMismatch "integer" whnf -fromRationalWHNF :: WHNFData -> Either EgisonError Rational-fromRationalWHNF (Value (Number (x, 0) (y, 0))) = return (x % y)-fromRationalWHNF whnf = throwError $ TypeMismatch "rational" whnf- fromFloatWHNF :: WHNFData -> Either EgisonError Double fromFloatWHNF (Value (Float f 0)) = return f fromFloatWHNF whnf = throwError $ TypeMismatch "float" whnf@@ -564,19 +1009,20 @@ -- Environment -- -type Env = [HashMap Var ObjectRef]+data Env = Env [HashMap Var ObjectRef]+ deriving (Show)+ type Var = String type Binding = (Var, ObjectRef)  nullEnv :: Env-nullEnv = []+nullEnv = Env []  extendEnv :: Env -> [Binding] -> Env-extendEnv env = (: env) . HashMap.fromList+extendEnv (Env env) = Env . (: env) . HashMap.fromList -refVar :: Env -> Var -> EgisonM ObjectRef-refVar env var = maybe (throwError $ UnboundVariable var) return-                       (msum $ map (HashMap.lookup var) env)+refVar :: Env -> Var -> Maybe ObjectRef+refVar (Env env) var = msum $ map (HashMap.lookup var) env  -- -- Pattern Match@@ -615,6 +1061,9 @@   | ArgumentsNumWithNames [String] Int Int   | ArgumentsNumPrimitive Int Int   | ArgumentsNum Int Int+  | InconsistentTensorSize+  | InconsistentTensorIndex+  | TensorIndexOutOfBounds Integer Integer   | NotImplemented String   | Assertion String   | Match String@@ -635,6 +1084,9 @@                                               show expected ++ ", but got " ++  show got   show (ArgumentsNum expected got) = "Wrong number of arguments: expected " ++                                       show expected ++ ", but got " ++  show got+  show InconsistentTensorSize = "Inconsistent tensor size"+  show InconsistentTensorIndex = "Inconsistent tensor index"+  show (TensorIndexOutOfBounds m n) = "Tensor index out of bounds: " ++ show m ++ ", " ++ show n   show (NotImplemented message) = "Not implemented: " ++ message   show (Assertion message) = "Assertion failed: " ++ message   show (Desugar message) = "Error: " ++ message@@ -771,3 +1223,89 @@  mfor :: Monad m => MList m a -> (a -> m b) -> m (MList m b) mfor = flip mmap++-- Typing++isBool :: EgisonValue -> Bool+isBool (Bool _) = True+isBool _ = False++isBool' :: PrimitiveFunc+isBool' (Value val) = return $ Value $ Bool $ isBool val++isInteger :: EgisonValue -> Bool+isInteger (ScalarData (Div (Plus []) (Plus [(Term 1 [])]))) = True+isInteger (ScalarData (Div (Plus [(Term _ [])]) (Plus [(Term 1 [])]))) = True+isInteger _ = False++isInteger' :: PrimitiveFunc+isInteger' (Value val) = return $ Value $ Bool $ isInteger val++isRational :: EgisonValue -> Bool+isRational (ScalarData (Div (Plus []) (Plus [(Term _ [])]))) = True+isRational (ScalarData (Div (Plus [(Term _ [])]) (Plus [(Term _ [])]))) = True+isRational _ = False++isRational' :: PrimitiveFunc+isRational' (Value val) = return $ Value $ Bool $ isRational val++isSymbol :: EgisonValue -> Bool+isSymbol (ScalarData (Div (Plus [(Term 1 [(Symbol _ _, 1)])]) (Plus [(Term 1 [])]))) = True+isSymbol _ = False++isNumber :: EgisonValue -> Bool+isNumber (ScalarData _) = True+isNumber _ = False++isNumber' :: PrimitiveFunc+isNumber' (Value val) = return $ Value $ Bool $ isNumber val+isNumber' _ = return $ Value $ Bool False++isTensor :: EgisonValue -> Bool+isTensor (TensorData _) = True+isTensor _ = False++isTensor' :: PrimitiveFunc+isTensor' (Value val) = return $ Value $ Bool $ isTensor val+isTensor' _ = return $ Value $ Bool False++isTensorWithIndex :: EgisonValue -> Bool+isTensorWithIndex (TensorData (TData (Tensor _ _) (Just ms))) = True+isTensorWithIndex _ = False++isTensorWithIndex' :: PrimitiveFunc+isTensorWithIndex' (Value val) = return $ Value $ Bool $ isTensorWithIndex val+isTensorWithIndex' _ = return $ Value $ Bool False++isFloat' :: PrimitiveFunc+isFloat' (Value (Float _ 0)) = return $ Value $ Bool True+isFloat' _ = return $ Value $ Bool False++isComplex' :: PrimitiveFunc+isComplex' (Value (Float _ _)) = return $ Value $ Bool True+isComplex' _ = return $ Value $ Bool False++isChar' :: PrimitiveFunc+isChar' (Value (Char _)) = return $ Value $ Bool True+isChar' _ = return $ Value $ Bool False++isString' :: PrimitiveFunc+isString' (Value (String _)) = return $ Value $ Bool True+isString' _ = return $ Value $ Bool False++isCollection' :: PrimitiveFunc+isCollection' (Value (Collection _)) = return $ Value $ Bool True+isCollection' (Intermediate (ICollection _)) = return $ Value $ Bool True+isCollection' _ = return $ Value $ Bool False++isArray' :: PrimitiveFunc+isArray' (Value (Array _)) = return $ Value $ Bool True+isArray' (Intermediate (IArray _)) = return $ Value $ Bool True+isArray' _ = return $ Value $ Bool False++isHash' :: PrimitiveFunc+isHash' (Value (IntHash _)) = return $ Value $ Bool True+isHash' (Value (StrHash _)) = return $ Value $ Bool True+isHash' (Intermediate (IIntHash _)) = return $ Value $ Bool True+isHash' (Intermediate (IStrHash _)) = return $ Value $ Bool True+isHash' _ = return $ Value $ Bool False

@@ -1,13 +0,0 @@-;;;;;-;;;;;-;;;;; Array-;;;;;-;;;;;--(define $A.map-  (lambda [$f $a]-    (generate-array [$i] (array-size a) (f a_i))))--(define $A.update-  (lambda [$f $i $a]-    (generate-array [$j] (array-size a) (if (eq? j i) (f a_j) a_j))))

@@ -0,0 +1,107 @@+;;;;;+;;;;;+;;;;; Assoc-Collection+;;;;;+;;;;;++(define $to-assoc+  (lambda [$xs]+    (match xs (list something)+      {[<nil> {}]+       [<cons $x (loop $i [2 $n]+                   <cons ,x ...>+                   (& !<cons ,x _> $rs))>+        {[x n] @(to-assoc rs)}]})))++(define $from-assoc+  (lambda [$xs]+    (match xs (list [something integer])+      {[<nil> {}]+       [<cons [$x $n] $rs>+        {@(take n (repeat1 x)) @(from-assoc rs)}]})))++;;;+;;; Assoc List+;;;++(define $assoc-list+  (lambda [$a]+    (matcher+      {[<nil> []+        {[{} {[]}]+         [_ {}]}]+       [<cons $ $> [a (assoc-list a)]+        {[$tgt (match tgt (list [something integer])+                 {[<cons [$x ,1] $rs> {[x rs]}]+                  [<cons [$x $n] $rs> {[x {[x (- n 1)] @rs}]}]+                  [_ {}]})]}]+       [<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)]+        {[$tgt (match tgt (list [something integer])+                 {[<cons [$x $k] $rs> {[k x rs]}]+                  [_ {}]})]}]+       [,$val []+        {[$tgt (if (eq? val tgt) {[]} {})]}]+       [$ [something]+        {[$tgt {tgt}]}]+       })))++;;;+;;; Assoc Multiset+;;;++(define $assoc-multiset+  (lambda [$a]+    (matcher+      {[<nil> []+        {[{} {[]}]+         [_ {}]}]+       [<cons ,$x $> [(assoc-multiset a)]+        {[$tgt (match-all tgt (list [a integer])+                 [<join $hs <cons [,x $n] $ts>>+                  (if (eq? n 1)+                    {@hs @ts}+                    {@hs [x (- n 1)] @ts})])]}]+       [<cons $ $> [a (assoc-multiset a)]+        {[$tgt (match-all tgt (list [a integer])+                 [<join $hs <cons [$x $n] $ts>>+                  (if (eq? n 1)+                    [x {@hs @ts}]+                    [x {@hs [x (- n 1)] @ts}])])]}]+       [<ncons ,$n ,$x $> [(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)]+        {[$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)]+        {[$tgt (match-all tgt (list [a integer])+                 [<join $hs <cons [,x $n] $ts>>+                  [n {@hs @ts}]])]}]+       [<ncons $ $ $> [integer a (assoc-multiset a)]+        {[$tgt (match-all tgt (list [a integer])+                 [<join $hs <cons [$x $n] $ts>>+                  [n x {@hs @ts}]])]}]+       [$ [something]+        {[$tgt {tgt}]}]+       })))++(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)]])))++(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)]])))

@@ -183,16 +183,47 @@        [[<cons $x $xs2> <cons $y $ys2>]         {(fn x y) @(map2 fn xs2 ys2)}]}))) +(define $map3+  (lambda [$fn $xs $ys $zs]+    (match [xs ys zs] [(list something) (list something) (list something)]+      {[[<nil> _ _] {}]+       [[_ <nil> _] {}]+       [[_ _ <nil>] {}]+       [[<cons $x $xs2> <cons $y $ys2> <cons $z $zs2>]+        {(fn x y z) @(map3 fn xs2 ys2 zs2)}]})))++(define $map4+  (lambda [$fn $xs $ys $zs $ws]+    (match [xs ys zs ws] [(list something) (list something) (list something) (list something)]+      {[[<nil> _ _ _] {}]+       [[_ <nil> _ _] {}]+       [[_ _ <nil> _] {}]+       [[_ _ _ <nil>] {}]+       [[<cons $x $xs2> <cons $y $ys2> <cons $z $zs2> <cons $w $ws2>]+        {(fn x y z w) @(map4 fn xs2 ys2 zs2 ws2)}]})))+ (define $filter   (lambda [$pred $xs]     (foldr (lambda [$y $ys] (if (pred y) {y @ys} ys))            {}            xs))) +(define $partition+  (lambda [$pred $xs]+    [(filter pred xs) (filter 1#(not (pred %1)) xs)]))+ (define $zip   (lambda [$xs $ys]     (map2 (lambda [$x $y] [x y]) xs ys))) +(define $zip3+  (lambda [$xs $ys $zs]+    (map3 (lambda [$x $y $z] [x y z]) xs ys zs)))++(define $zip4+  (lambda [$xs $ys $zs $ws]+    (map4 (lambda [$x $y $z $w] [x y z w]) xs ys zs ws)))+ (define $lookup   (lambda [$k $ls]     (match ls (list [something something])@@ -213,12 +244,25 @@         (let {[$z (fn init x)]}           (seq z (foldl fn z xs)))]}))) +(define $reduce+  (lambda [$fn $ls]+    (foldl fn (car ls) (cdr ls))))+ (define $scanl   (lambda [$fn $init $ls]     {init @(match ls (list something)              {[<nil> {}]               [<cons $x $xs> (scanl fn (fn init x) xs)]})})) +(define $iterate+  (lambda [$fn $x]+    (let* {[$nx1 (fn x)]+           [$nx2 (fn nx1)]+           [$nx3 (fn nx2)]+           [$nx4 (fn nx3)]+           [$nx5 (fn nx4)]}+      {x nx1 nx2 nx3 nx4 @(iterate fn nx5)})))+ (define $append   (lambda [$xs $ys]     {@xs @ys}))@@ -415,14 +459,14 @@   (lambda [$xs $ys]     {@xs      @(match-all [ys xs] [(multiset something) (multiset something)]-        [[<cons $y _> ^<cons ,y _>] y])+        [[<cons $y _> !<cons ,y _>] y])      }))  (define $union/m   (lambda [$a $xs $ys]     {@xs      @(match-all [ys xs] [(multiset a) (multiset a)]-        [[<cons $y _> ^<cons ,y _>] y])+        [[<cons $y _> !<cons ,y _>] y])      }))  (define $intersect@@ -517,7 +561,7 @@ (define $unique   (lambda [$xs]     (match-all (sort xs) (list something)-      [<join _ <cons $x ^<cons ,x _>>> x])))+      [<join _ <cons $x !<cons ,x _>>> x])))  (define $unique/m   (lambda [$a $xs]

@@ -51,19 +51,12 @@ (define $prime-factorization   (match-lambda integer     {[,1 {}]+     [(& ?(lt? $ 0) $n) {-1 @(prime-factorization (neg n))}]      [$n (let {[$p (find-factor n)]}            {p @(prime-factorization (quotient n p))})]}))  (define $p-f prime-factorization) -(define $n-adic-  (lambda [$n $x]-    (if (eq? x 0)-      {}-      (let {[$q (quotient x n)]-            [$r (remainder x n)]}-        {@(n-adic n q) r}))))- (define $even?   (lambda [$n]     (eq? 0 (modulo n 2))))@@ -72,18 +65,6 @@   (lambda [$n]     (eq? 1 (modulo n 2)))) -(define $square?-  (lambda [$n]-    (let {[$x (round (sqrt n))]}-      (eq? n (power x 2)))))--(define $gcd-  (lambda [$ns]-    (match ns (multiset integer)-      {[<cons $n <nil>> n]-       [<cons (& ,(min ns) $m) $rs>-        (gcd {m @(delete 0 (map (lambda [$r] (modulo r m)) rs))})]})))- (define $fact   (lambda [$n]     (foldl * 1 (between 1 n))))@@ -97,6 +78,14 @@     (/ (perm n r)        (fact r)))) +(define $n-adic+  (lambda [$n $x]+    (if (eq? x 0)+      {}+      (let {[$q (quotient x n)]+            [$r (remainder x n)]}+        {@(n-adic n q) r}))))+ ;;; ;;; Integers ;;;@@ -111,17 +100,12 @@         {[$tgt {tgt}]}]        }))) -(define $power-  (lambda [$x $n]-    (foldl * 1 (take n (repeat1 x)))))--(define $sum-  (lambda [$xs]-    (foldl + 0 xs)))--(define $product-  (lambda [$xs]-    (foldl * 1 xs)))+;;;+;;; Floats+;;;+(define $exp2+  (lambda [$x $y]+    (exp (* (log x) y))))  ;;; ;;; Decimal Fractions@@ -178,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 m))))]+    (let* {[$n (floor (+ (rtof a) (* (rtof b) (sqrt (rtof m)))))]            [$x (- m (power n 2))]}       (if (eq? x 0)         {[a b n]}@@ -187,7 +171,7 @@  (define $regular-continued-fraction-of-sqrt   (lambda [$m]-    (let* {[$n (floor (sqrt m))]+    (let* {[$n (floor (sqrt (rtof m)))]            [$x (- m (power n 2))]}       ; n+rt(m)-n       ; n+(rt(m)-n)*(rt(m)+n)/(rt(m)+n)@@ -198,7 +182,7 @@  (define $regular-continued-fraction-of-sqrt'   (lambda [$m]-    (let* {[$n (floor (sqrt m))]+    (let* {[$n (floor (sqrt (rtof m)))]            [$x (- m (power n 2))]}       (if (eq? x 0)         [n {} {}]

@@ -27,41 +27,24 @@        [[<cons $x $xs> <cons ,x $ys>] (compare-c xs ys)]        [[<cons $x _> <cons $y _>] (compare x y)]}))) -(define $min-  (lambda [$ns]-    (foldl 2#(if (lt? %1 %2) %1 %2) (car ns) (cdr ns))))--(define $max-  (lambda [$ns]-    (foldl 2#(if (gt? %1 %2) %1 %2) (car ns) (cdr ns))))+(define $b.min+  (lambda [$x $y]+    (if (lt? x y) x y))) -(define $min-and-max-  (lambda [$ns]-    (foldl (lambda [$ret $x]-             (match ret [integer integer]-               {[[$min $max] (if (lt? x min) [x max]-                               (if (gt? x min) [min x]-                                 [min max]))]}))-           [(car ns) (car ns)]-           (cdr ns))))+(define $b.max+  (lambda [$x $y]+    (if (gt? x y) x y)))  (define $min/fn-  (lambda [$compare $ns]-    (foldl 2#(if (eq? (compare %1 %2) <Less>) %1 %2) (car ns) (cdr ns))))+  (lambda [$compare $x $y]+    (if (eq? (compare x y) <Less>) x y)))  (define $max/fn-  (lambda [$compare $ns]-    (foldl 2#(if (eq? (compare %1 %2) <Greater>) %1 %2) (car ns) (cdr ns))))+  (lambda [$compare $x $y]+    (if (eq? (compare x y) <Greater>) x y))) -(define $min-and-max/fn-  (lambda [$compare $ns]-    (foldl (lambda [$ret $x]-             (match ret [integer integer]-               {[[$min $max] (if (eq? (compare x min) <Less>) [x max]-                               (if (eq? (compare x min) <Greater>) [min x]-                                 [min max]))]}))-           [(car ns) (car ns)]-           (cdr ns))))+(define $min (cambda $xs (foldl b.min (car xs) (cdr xs))))+(define $max (cambda $xs (foldl b.max (car xs) (cdr xs))))  (define $split-by-ordering (split-by-ordering/fn compare $ $)) 

@@ -2,6 +2,10 @@ ;;;;; Random ;;;;; +(define $rands+  (lambda [$s $e]+    {(pure-rand s e) @(rands s e)}))+ (define $pure-rand   (lambda [$s $e]     (io (rand s e))))

@@ -20,12 +20,12 @@                {(uncons-string tgt)})]}]      [<join $ <cons ,$px $>> [string string]       {[$tgt (match-all (S.split (pack {px}) tgt) (list string)-               [<join (& ^<nil> $xs) (& ^<nil> $ys)> [(S.intercalate (pack {px}) xs)+               [<join (& !<nil> $xs) (& !<nil> $ys)> [(S.intercalate (pack {px}) xs)                                 (S.intercalate (pack {px}) ys)                                 ]])]}]      [<join $ <join ,$pxs $>> [string string]       {[$tgt (match-all (S.split pxs tgt) (list string)-               [<join (& ^<nil> $xs) (& ^<nil> $ys)> [(S.intercalate pxs xs)+               [<join (& !<nil> $xs) (& !<nil> $ys)> [(S.intercalate pxs xs)                                 (S.intercalate pxs ys)                                 ]])]}]      [<join $ $> [string string]

@@ -0,0 +1,62 @@+;;;;;+;;;;;+;;;;; Equations+;;;;;+;;;;;++(define $solve1+  (lambda [$f $expr $x]+    (inverse expr f x)))++(define $solve+  (lambda [$eqs]+    (solve' eqs {})))++(define $solve'+  (lambda [$eqs $rets]+    (match eqs (list [math-expr math-expr symbol-expr])+      {[<nil> rets]+       [<cons [$f $expr $x] $rs>+        (solve' rs {@rets [x (solve1 (substitute rets f) (substitute rets expr) x)]})]})))++;;;+;;; Quadratic Equations+;;;+(define $quadratic-formula q-f)++(define $q-f+  (lambda [$f $x]+    (match (coefficients f x) (list math-expr)+      {[<cons $a_0 <cons $a_1 <cons $a_2 <nil>>>>+        (q-f' a_2 a_1 a_0)]})))++(define $q-f'+  (lambda [$a $b $c]+    [(/ (+ (* -1 b) (sqrt (- (** b 2) (* 4 a c)))) (* 2 a))+     (/ (- (* -1 b) (sqrt (- (** b 2) (* 4 a c)))) (* 2 a))]))++;;;+;;; Cubic Equations+;;;+(define $cubic-formula c-f)++(define $c-f+  (lambda [$f $x]+    (match (coefficients f x) (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)]})))++(define $c-f'+  (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))]+          )]+       [[_ _ _ _] (c-f' 1 (/ b a) (/ c a) (/ d a))]})))

@@ -0,0 +1,44 @@+;;;;;+;;;;; Inverse+;;;;;++; (inverse t (* a x^2) x)+; t = (* a x^2)+; x = (sqrt (/ t a))++(define $inverse+  (lambda [$t $f $x]+    (match f math-expr+      {[?simple-term?+        (match f symbol-expr+          {[,x t]+           [(,exp ,x) (log t)]+           [(,log ,x) (exp t)]+           [(,sqrt ,x) (** t 2)]+           [(,cos ,x) (acos t)]+           [(,sin ,x) (asin t)]+           [(,acos ,x) (cos t)]+           [(,asin ,x) (sin t)]+           [_ (inverse' t f x)]+           })]+       [?term?+        (match f term-expr+          {[<term ,1 <ncons $n ,x <nil>>> (rt n t)]+           [<term _ <ncons $n ,x _>>+            (let {[$a (/ f (** x n))]}+              (inverse (/ t a) (/ f a) x))]+           [_ (inverse' t f x)]})]+       [?polynomial?+        (match (coefficients f x) (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)]})]+       [_+        (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})>)))

@@ -0,0 +1,80 @@+;;;;;+;;;;;+;;;;; Algebra+;;;;;+;;;;;++;;;+;;; Root+;;;++(define $rt+  (lambda [$n $x]+    (if (integer? n)+      (match x math-expr+        {[,0 0]+         [?monomial? (rt' n x)]+         [<div <plus $xs> <plus $ys>>+          (let {[$xd (reduce gcd xs)]+                [$yd (reduce gcd ys)]}+            (let {[[$a $r] (from-monomial (rt' n (/ xd yd)))]}+              (*' a+                 (rt'' n (*' (** r n) (/' (sum' (map (/' $ xd) xs)) (sum' (map (/' $ yd) ys)))))+                 )))]})+      (rt'' n x))))++(define $rt'+  (lambda [$n $x]+    (letrec {[$f (lambda [$xs]+                   (match xs (assoc-multiset integer)+                     {[<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)))))))++(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})>)]})))++(define $rtm1+  (lambda [$n]+    (match n integer+      {[,1 -1]+       [,2 i]+       [?odd? -1]+       [_ undefined]})))++(define $sqrt+  (lambda [$x]+    (if (number? x)+      (let {[$m (numerator x)]+            [$n (denominator x)]}+        (/ (rt 2 (* m n)) n))+      (b.sqrt x))))++(define $rt-of-unity rtu)++(define $rtu+  (lambda [$n]+    (rtu' n)))++(define $rtu'+  (lambda [$n]+    (if (integer? n)+      (match n integer+        {[,1 1]+         [,2 -1]+         [,3 w]+         [,4 i]+         [_ (to-math-expr' <Apply rtu (map from-math-expr {n})>)]+         })+      (to-math-expr' <Apply rtu (map from-math-expr {n})>))))

@@ -0,0 +1,163 @@+;;;;;+;;;;;+;;;;; Tensor+;;;;;+;;;;;++(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))))++(define $zero-tensor+  (lambda [$ns]+    (generate-tensor (cambda $ns 0) ns)))++(define $T.unit (unit-tensor $))+(define $T.zero (zero-tensor $))++;;+;; 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 $T.+ (T.arith +))+(define $T.- (T.arith -))++;;+;; 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]})))

@@ -0,0 +1,55 @@+;;;;;+;;;;;+;;;;; Differentiation+;;;;;+;;;;;++(define $d/d+  (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)))]+           })]+       })))++(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 $taylor-expansion+  (lambda [$f $x $a]+    (map2 *+          (map 1#(/ (** (- x a) %1) (fact %1)) nats0)+          (map (substitute {[x a]} $) (iterate (d/d $ x) f)))))++(define $maclaurin-expansion (taylor-expansion $ $ 0))

@@ -0,0 +1,61 @@+;;;;;+;;;;;+;;;;; Integration+;;;;;+;;;;;++(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)]})]})]+       })))++(define $multSd+  (lambda [$x $f $g]+    (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]+    (let {[$F (Sd x f)]}+      (- (substitute {[x b]} F)+         (substitute {[x a]} F)))))

@@ -0,0 +1,93 @@+;;;;;+;;;;;+;;;;; Arithmetic Operation+;;;;;+;;;;;++(define $to-math-expr (macro [$arg] (math-normalize (apply to-math-expr' arg))))++(define $+' (cambda $xs (foldl b.+' (car xs) (cdr xs))))+(define $-' (cambda $xs (foldl b.-' (car xs) (cdr xs))))+(define $*' (cambda $xs (foldl b.*' (car xs) (cdr xs))))+(define $/' b./')+(define $.' (cambda $xs (foldl b..' (car xs) (cdr xs))))++(define $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 $+ (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 $sum+  (lambda [$xs]+    (foldl + 0 xs)))++(define $sum'+  (lambda [$xs]+    (foldl +' 0 xs)))++(define $product+  (lambda [$xs]+    (foldl * 1 xs)))++(define $product'+  (lambda [$xs]+    (foldl *' 1 xs)))++(define $power+  (lambda [$x $n]+    (foldl * 1 (take n (repeat1 x)))))++(define $power'+  (lambda [$x $n]+    (foldl *' 1 (take n (repeat1 x)))))++(define $**+  (lambda [$x $n]+    (if (eq? x e)+      (exp 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})>)))))++(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})>))))++(define $gcd+  (cambda $xs+    (foldl b.gcd (car xs) (cdr xs))))++(define $gcd'+  (cambda $xs+    (foldl b.gcd' (car xs) (cdr xs))))++(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))))]})))++(define $b.gcd'+  (lambda [$x $y]+    (match [x y] [integer integer]+      {[[,0 _] y]+       [[_ ,0] x]+       [[_ ?(gte? $ x)] (b.gcd' (modulo y x) x)]+       [[_ _] (b.gcd' y x)]})))

@@ -0,0 +1,96 @@+;;;;;+;;;;;+;;;;; Mathematical Functions+;;;;;+;;;;;++(define $exp+  (lambda [$x]+    (if (float? x)+      (b.exp x)+      (if (term? x)+        (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})>)))))++(define $log+  (lambda [$x]+    (if (float? x)+      (b.log x)+      (match x math-expr+        {[,1 0]+         [,e 1]+         [_ (to-math-expr <Apply log (map from-math-expr {x})>)]}))))++(define $cos+  (lambda [$x]+    (if (float? x)+      (b.cos x)+      (match x math-expr+        {[,0 1]+         [,(* 2 pi) 1]+         [_ (to-math-expr <Apply cos (map from-math-expr {x})>)]}))))++(define $sin+  (lambda [$x]+    (if (float? x)+      (b.sin x)+      (match x math-expr+        {[,0 0]+         [_ (to-math-expr <Apply sin (map from-math-expr {x})>)]}))))++(define $tan+  (lambda [$x]+    (if (float? x)+      (b.tan x)+      (match x math-expr+        {[,0 0]+         [_ (to-math-expr <Apply tan (map from-math-expr {x})>)]}))))++(define $cosh+  (lambda [$x]+    (if (float? x)+      (b.cosh x)+      (match x math-expr+        {[,0 1]+         [_ (to-math-expr <Apply cosh (map from-math-expr {x})>)]}))))++(define $sinh+  (lambda [$x]+    (if (float? x)+      (b.sinh x)+      (match x math-expr+        {[,0 0]+         [_ (to-math-expr <Apply sinh (map from-math-expr {x})>)]}))))++(define $tanh+  (lambda [$x]+    (if (float? x)+      (b.tanh x)+      (match x math-expr+        {[,0 0]+         [_ (to-math-expr <Apply tanh (map from-math-expr {x})>)]}))))+++(define $sinc+  (lambda [$x]+    (if (float? x)+      (if (eq? x 0.0)+        1.0+        (/ (b.sin x) x))+      (match x math-expr+        {[,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)))

@@ -0,0 +1,242 @@+;;;;;+;;;;;+;;;;; Mathematics Expressions+;;;;;+;;;;;++(define $math-expr+  (matcher+    {[,$val []+      {[$tgt (if (eq? val tgt)+               {[]}+               {})]}]+     [$ [math-expr']+      {[<Div $p1 $p2> {<Div p1 p2>}]+       [$tgt {(from-math-expr tgt)}]}]+     }))++(define $math-expr'+  (matcher+    {[<div $ $> [poly-expr poly-expr]+      {[<Div $p1 $p2> {[(to-math-expr' p1) (to-math-expr' p2)]}]+       [_ {}]}]+     [$ [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 $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 $term-expr+  (matcher+    {[,$val []+      {[$tgt (if (eq? val tgt)+               {[]}+               {})]}]+     [<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)}]}]+     }))++(define $symbol-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)}]}]+     }))++(define $symbol?+  (lambda [$mexpr]+    (match mexpr math-expr+      {[<div <plus <cons <term ,1 <cons <symbol _> <nil>>> <nil>>>+             <plus <cons <term ,1 <nil>> <nil>>>>+        #t]+       [_ #f]})))++(define $simple-term?+  (lambda [$mexpr]+    (match mexpr math-expr+      {[<div <plus <cons <term ,1 <cons _ <nil>>> <nil>>>+             <plus <cons <term ,1 <nil>> <nil>>>>+        #t]+       [,0 #t]+       [_ #f]})))++(define $term?+  (lambda [$mexpr]+    (match mexpr math-expr+      {[<div <plus <cons _ <nil>>>+             <plus <cons <term ,1 <nil>> <nil>>>>+        #t]+       [,0 #t]+       [_ #f]})))++(define $polynomial?+  (lambda [$mexpr]+    (match mexpr math-expr+      {[<div _+             <plus <cons <term ,1 <nil>> <nil>>>>+        #t]+       [,0 #t]+       [_ #f]})))++(define $monomial?+  (lambda [$mexpr]+    (match mexpr math-expr+      {[<div <plus <cons <term _ _> <nil>>>+             <plus <cons <term _ _> <nil>>>>+        #t]+       [,0 #t]+       [_ #f]})))++(define $from-monomial+  (lambda [$mexpr]+    (match mexpr math-expr+      {[<div <plus <cons <term $a $xs> <nil>>>+             <plus <cons <term $b $ys> <nil>>>>+        [(/ a b)+         (/ (foldl *' 1 (map 2#(**' %1 %2) xs))+            (foldl *' 1 (map 2#(**' %1 %2) ys)))]]})))++;;+;; Map+;;+(define $map-terms+  (lambda [$fn $mexpr]+    (match mexpr math-expr+      {[<div <plus $ts1> <plus $ts2>>+        (/' (foldl +' 0 (map fn ts1))+            (foldl +' 0 (map fn ts2)))]})))++(define $map-symbols+  (lambda [$fn $mexpr]+    (map-terms (lambda [$term]+                 (match term term-expr+                   {[<term $a $xs>+                     (*' a (foldl *' 1 (map 2#(match %1 symbol-expr+                                                {[<symbol _> (**' (fn %1) %2)]+                                                 [<apply $g $args>+                                                  (** (fn (capply g (map (map-symbols fn $) args)))+                                                      %2)+                                                  ]})+                                            xs)))]}))+               mexpr)))++(define $contain-symbol?+  (lambda [$x $mexpr]+    (any id (match mexpr math-expr+              {[<div <plus $ts1> <plus $ts2>>+                (map (lambda [$term]+                       (match term term-expr+                         {[<term _ $xs>+                           (any id (map 2#(match %1 symbol-expr+                                            {[,x #t]+                                             [<apply _ $args> (any id (map (contain-symbol? x $) 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))]}))))++(define $substitute'+  (lambda [$x $a $mexpr]+    (map-symbols (rewrite-symbol x a $) mexpr)))++(define $rewrite-symbol +  (lambda [$x $a $sexpr]+    (match sexpr symbol-expr+      {[,x a]+       [_ sexpr]})))++;;;+;;; Coefficient+;;;+(define $coefficients+  (lambda [$f $x]+    (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)))))++(define $coefficient+  (lambda [$f $x $m]+    (if (eq? m 0)+      (/ (sum (match-all f math-expr+                [<div <plus <cons <term $a (& !<cons ,x _> $ts)> _>> _>+                 (foldl *' a (map 2#(**' %1 %2) ts))]))+         (denominator f))+      (coefficient' f x m))))++(define $coefficient'+  (lambda [$f $x $m]+    (/ (sum (match-all f math-expr+              [<div <plus <cons <term $a <ncons $k ,x $ts>> _>> _>+               (if (eq? m k)+                 (foldl *' a (map 2#(**' %1 %2) ts))+                 0)]))+       (denominator f))))

@@ -0,0 +1,74 @@+;;;;;+;;;;;+;;;;; Term Rewriting+;;;;;+;;;;;++;(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))))++(define $rewrite-rule-i+  (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)))]+       [_ term]})))++(define $rewrite-rule-w+  (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)))]+       [_ term]})))++(define $rewrite-rule-rtu+  (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)))]+       [_ term]})))++(define $rewrite-rule-sqrt+  (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>>>+        (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))))]+       [_ term]})))++(define $rewrite-rule-rt+  (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)))]+       [_ term]})))

@@ -48,14 +48,14 @@                 (match-all bipartite-graph-data (bipartite-graph integer string)                   [<cons <edge $n $str>                          <cons <edge ,n ,str>-                               ^<cons <edge ,n ^,str> _>>>+                               !<cons <edge ,n !,str> _>>>                    n])))  (test (unique/m integer                 (match-all bipartite-graph-data (bipartite-graph integer string)                   [<cons <edge $n $str>                          <cons <edge ,n ,str>-                               ^<cons <edge ,n ^,str> _>>>+                               !<cons <edge ,n !,str> _>>>                    n])))  (test (unique/m integer@@ -76,12 +76,12 @@ ;                  [(& <cons <edge $n $str> ;                            <cons <edge ,n ,str> ;                                  <cons <edge ,n ,str> _>>>-;                      ^<cons <edge $n2 $str2>-;                             ^<cons <edge ,n2 ,str2> _>>)+;                      !<cons <edge $n2 $str2>+;                             !<cons <edge ,n2 ,str2> _>>) ;                   n])))  (test (unique/m integer                 (match-all bipartite-graph-data (bipartite-graph integer string)                   [<cons <edge $n2 $str2>-                         ^<cons <edge ,n2 ,str2> _>>+                         !<cons <edge ,n2 ,str2> _>>                   n2])))

@@ -51,7 +51,7 @@ (test (let {[$s 1]}         (match-all graph-data1 (graph integer)           [<cons <edge ,s $x>-                 ^<cons <edge ,x ,s>+                 !<cons <edge ,x ,s>                         _>>            x]))) 

@@ -1,40 +1,40 @@ (define $eight-queen   (match-all {1 2 3 4 5 6 7 8} (multiset integer)     [<cons $a_1-      <cons (& ^,(- a_1 1) ^,(+ a_1 1)+      <cons (& !,(- a_1 1) !,(+ a_1 1)                $a_2)-       <cons (& ^,(- a_1 2) ^,(+ a_1 2)-                ^,(- a_2 1) ^,(+ a_2 1)+       <cons (& !,(- a_1 2) !,(+ a_1 2)+                !,(- a_2 1) !,(+ a_2 1)                 $a_3)-        <cons (& ^,(- a_1 3) ^,(+ a_1 3)-                 ^,(- a_2 2) ^,(+ a_2 2)-                 ^,(- a_3 1) ^,(+ a_3 1)+        <cons (& !,(- a_1 3) !,(+ a_1 3)+                 !,(- a_2 2) !,(+ a_2 2)+                 !,(- a_3 1) !,(+ a_3 1)                  $a_4)-          <cons (& ^,(- a_1 4) ^,(+ a_1 4)-                   ^,(- a_2 3) ^,(+ a_2 3)-                   ^,(- a_3 2) ^,(+ a_3 2)-                   ^,(- a_4 1) ^,(+ a_4 1)+          <cons (& !,(- a_1 4) !,(+ a_1 4)+                   !,(- a_2 3) !,(+ a_2 3)+                   !,(- a_3 2) !,(+ a_3 2)+                   !,(- a_4 1) !,(+ a_4 1)                    $a_5)-           <cons (& ^,(- a_1 5) ^,(+ a_1 5)-                    ^,(- a_2 4) ^,(+ a_2 4)-                    ^,(- a_3 3) ^,(+ a_3 3)-                    ^,(- a_4 2) ^,(+ a_4 2)-                    ^,(- a_5 1) ^,(+ a_5 1)+           <cons (& !,(- a_1 5) !,(+ a_1 5)+                    !,(- a_2 4) !,(+ a_2 4)+                    !,(- a_3 3) !,(+ a_3 3)+                    !,(- a_4 2) !,(+ a_4 2)+                    !,(- a_5 1) !,(+ a_5 1)                     $a_6)-            <cons (& ^,(- a_1 6) ^,(+ a_1 6)-                     ^,(- a_2 5) ^,(+ a_2 5)-                     ^,(- a_3 4) ^,(+ a_3 4)-                     ^,(- a_4 3) ^,(+ a_4 3)-                     ^,(- a_5 2) ^,(+ a_5 2)-                     ^,(- a_6 1) ^,(+ a_6 1)+            <cons (& !,(- a_1 6) !,(+ a_1 6)+                     !,(- a_2 5) !,(+ a_2 5)+                     !,(- a_3 4) !,(+ a_3 4)+                     !,(- a_4 3) !,(+ a_4 3)+                     !,(- a_5 2) !,(+ a_5 2)+                     !,(- a_6 1) !,(+ a_6 1)                      $a_7)-             <cons (& ^,(- a_1 7) ^,(+ a_1 7)-                      ^,(- a_2 6) ^,(+ a_2 6)-                      ^,(- a_3 5) ^,(+ a_3 5)-                      ^,(- a_4 4) ^,(+ a_4 4)-                      ^,(- a_5 3) ^,(+ a_5 3)-                      ^,(- a_6 2) ^,(+ a_6 2)-                      ^,(- a_7 1) ^,(+ a_7 1)+             <cons (& !,(- a_1 7) !,(+ a_1 7)+                      !,(- a_2 6) !,(+ a_2 6)+                      !,(- a_3 5) !,(+ a_3 5)+                      !,(- a_4 4) !,(+ a_4 4)+                      !,(- a_5 3) !,(+ a_5 3)+                      !,(- a_6 2) !,(+ a_6 2)+                      !,(- a_7 1) !,(+ a_7 1)                       $a_8)               <nil>>>>>>>>>      a]))@@ -47,8 +47,8 @@       [<cons $a_1              (loop $i [2 n]                    <cons (loop $i1 [1 (- i 1)]-                               (& ^,(- a_i1 (- i i1))-                                  ^,(+ a_i1 (- i i1))+                               (& !,(- a_i1 (- i i1))+                                  !,(+ a_i1 (- i i1))                                   ...)                                $a_i)                          ...>

@@ -2,7 +2,7 @@ (test (match-all {1 2 3 4 3 5 2 6} (multiset integer) [<cons $x <cons ,x _>> x]))  ; enumerate the elements of the collection that appear only once-(test (match-all {1 2 3 4 3 5 2 6} (multiset integer) [<cons $x ^<cons ,x _>> x]))+(test (match-all {1 2 3 4 3 5 2 6} (multiset integer) [<cons $x !<cons ,x _>> x]))  ; enumerate the elements of the collection if all of the three consecutive numbers from it are contained in the collection. (test (match-all {1 2 13 14 3 15 2 6} (multiset integer) [<cons $x <cons ,(+ x 1) <cons ,(+ x 2) _>>> x]))

@@ -16,7 +16,7 @@      [[$p $n ,0 $r  _] (R.sat-solver p n (- r 1))]      [[$p $n $k $r $a]       (match (randomize p) (multiset (R.multiset [integer bool]))-        {[<cons (& ^?(clause-satisfy? $ a) <cons [$i _] _>) _>+        {[<cons (& !?(clause-satisfy? $ a) <cons [$i _] _>) _>           (random-walk-3sat p n (- k 1) r (A.update not i a))]          [_ <Just a>]})]})) 

@@ -11,7 +11,7 @@ (match-all points (list [integer integer])   [<join _ <cons $p1     <join _ <cons $p2-     <join _ <cons (& ^?(on-a-line? p1 p2 $) $p3)+     <join _ <cons (& !?(on-a-line? p1 p2 $) $p3)        _>>>>>>    [p1 p2 p3]]) ;=>{[[3 1] [4 5] [7 7]] [[3 1] [4 5] [8 1]] [[3 1] [7 7] [8 1]] [[4 5] [7 7] [8 1]] [[3 1] [7 7] [1 9]] [[3 1] [8 1] [1 9]] [[4 5] [7 7] [1 9]] [[4 5] [8 1] [1 9]] [[7 7] [8 1] [1 9]] [[3 1] [4 5] [3 8]] [[3 1] [7 7] [3 8]] [[3 1] [8 1] [3 8]] [[3 1] [1 9] [3 8]] [[4 5] [7 7] [3 8]] [[4 5] [8 1] [3 8]] [[4 5] [1 9] [3 8]] [[7 7] [8 1] [3 8]] [[7 7] [1 9] [3 8]] [[8 1] [1 9] [3 8]] [[4 5] [7 7] [3 1]] [[4 5] [8 1] [3 1]] [[4 5] [1 9] [3 1]] [[4 5] [3 8] [3 1]] [[7 7] [8 1] [3 1]] [[7 7] [1 9] [3 1]] [[7 7] [3 8] [3 1]] [[8 1] [1 9] [3 1]] [[8 1] [3 8] [3 1]] [[1 9] [3 8] [3 1]]}