diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 3.6.0 +Version: 3.6.1 Synopsis: Programming language with non-linear pattern-matching against non-free data Description: An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language. @@ -68,7 +68,7 @@ location: https://github.com/egison/egison.git Library - Build-Depends: base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process + Build-Depends: base >= 4.0 && < 5, array, random, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, text, regex-tdfa, process, vector Hs-Source-Dirs: hs-src Exposed-Modules: Language.Egison @@ -79,7 +79,7 @@ Language.Egison.Primitives Language.Egison.Util Other-modules: Paths_egison - ghc-prof-options: -prof -auto-all + ghc-prof-options: --enable-profiling -auto-all Test-Suite test Type: exitcode-stdio-1.0 @@ -97,8 +97,8 @@ Executable egison Main-is: egison.hs - Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, text, regex-tdfa, process + Build-depends: egison, base >= 4.0 && < 5, array, containers, unordered-containers, haskeline, transformers, mtl, parsec >= 3.0, directory, ghc, ghc-paths, filepath, text, regex-tdfa, process, vector Hs-Source-Dirs: hs-src/Interpreter Other-modules: Paths_egison ghc-options: -rtsopts -threaded - ghc-prof-options: -prof -auto-all + ghc-prof-options: --enable-profiling -auto-all diff --git a/elisp/egison-mode.el b/elisp/egison-mode.el --- a/elisp/egison-mode.el +++ b/elisp/egison-mode.el @@ -40,6 +40,8 @@ (list "\\" "\\" + "\\" + "\\" "\\" "\\" "\\" @@ -49,16 +51,23 @@ "\\" "\\" "\\" + "\\" "\\" "\\" "\\" "\\" + "\\" "\\" "\\" ; "\\" + "\\" "\\" "\\" "\\" + "\\" + "\\" + "\\" + "\\" "\\" "\\" @@ -86,12 +95,14 @@ "\\\.\\\.\\\." "\\\," +; "'" + "`" "\\\#" "|" "\\\&" "@" "!" - "\\<_\\>" +; "\\<_\\>" "\\" "\\" @@ -174,17 +185,21 @@ ((equal "execute" name) 2) ((equal "lambda" name) 2) ((equal "cambda" name) 2) + ((equal "procedure" name) 2) ((equal "macro" name) 2) ((equal "memoized-lambda" name) 2) ((equal "memoize" name) 2) ((equal "letrec" name) 2) ((equal "let" name) 2) ((equal "let*" name) 2) + ((equal "with-symbols" name) 2) ((equal "if" name) 2) ((equal "apply" name) 2) ((equal "generate-array" name) 2) ((equal "array-size" name) 2) ((equal "array-ref" name) 2) + ((equal "generate-tensor" name) 2) + ((equal "tensor-map" name) 2) ((equal "loop" name) 2) ((equal "match" name) 2) ((equal "match-lambda" name) 2) @@ -236,7 +251,7 @@ (set (make-local-variable 'font-lock-defaults) '((egison-font-lock-keywords egison-font-lock-keywords-1 egison-font-lock-keywords-2) - nil t (("+-*/=?%:_.'" . "w") ("<" . "(") (">" . ")")) + nil t (("+-*/=!?%:_~.'∂∇α-ωΑ-Ω" . "w") ("<" . "(") (">" . ")")) )) (set (make-local-variable 'indent-line-function) 'egison-indent-line) (set (make-local-variable 'comment-start) ";") diff --git a/hs-src/Interpreter/egison.hs b/hs-src/Interpreter/egison.hs --- a/hs-src/Interpreter/egison.hs +++ b/hs-src/Interpreter/egison.hs @@ -217,7 +217,7 @@ showBanner :: IO () showBanner = do putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2016 Satoshi Egi" - putStrLn $ "http://www.egison.org" + putStrLn $ "https://www.egison.org" putStrLn $ "Welcome to Egison Interpreter!" -- putStrLn $ "** Information **" -- putStrLn $ "We can use the tab key to complete keywords on the interpreter." diff --git a/hs-src/Language/Egison.hs b/hs-src/Language/Egison.hs --- a/hs-src/Language/Egison.hs +++ b/hs-src/Language/Egison.hs @@ -108,12 +108,15 @@ [ "lib/math/expression.egi" , "lib/math/normalize.egi" , "lib/math/common/arithmetic.egi" + , "lib/math/common/constants.egi" , "lib/math/common/functions.egi" , "lib/math/algebra/root.egi" , "lib/math/algebra/equations.egi" , "lib/math/algebra/inverse.egi" , "lib/math/analysis/derivative.egi" , "lib/math/analysis/integral.egi" + , "lib/math/algebra/vector.egi" + , "lib/math/algebra/matrix.egi" , "lib/math/algebra/tensor.egi" , "lib/core/base.egi" , "lib/core/collection.egi" diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -58,6 +58,7 @@ import qualified Data.HashMap.Lazy as HL import Data.Array ((!)) import qualified Data.Array as Array +import qualified Data.Vector as V import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -81,7 +82,7 @@ collectDefs :: [EgisonTopExpr] -> [(String, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(String, EgisonExpr)], [EgisonTopExpr]) collectDefs (expr:exprs) bindings rest = case expr of - Define name expr -> collectDefs exprs ((name, expr) : bindings) rest + Define name expr -> collectDefs exprs ((show name, expr) : bindings) rest Load file -> do exprs' <- loadLibraryFile file collectDefs (exprs' ++ exprs) bindings rest @@ -102,7 +103,7 @@ collectDefs :: [EgisonTopExpr] -> [(String, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(String, EgisonExpr)], [EgisonTopExpr]) collectDefs (expr:exprs) bindings rest = case expr of - Define name expr -> collectDefs exprs ((name, expr) : bindings) rest + Define name expr -> collectDefs exprs ((show name, expr) : bindings) rest Load file -> do exprs' <- loadLibraryFile file collectDefs (exprs' ++ exprs) bindings rest @@ -110,6 +111,7 @@ exprs' <- loadFile file collectDefs (exprs' ++ exprs) bindings rest Test _ -> collectDefs exprs bindings (expr : rest) + Redefine _ _ -> collectDefs exprs bindings (expr : rest) _ -> collectDefs exprs bindings rest collectDefs [] bindings rest = return (bindings, reverse rest) @@ -123,7 +125,7 @@ collectDefs :: [EgisonTopExpr] -> [(String, EgisonExpr)] -> [EgisonTopExpr] -> EgisonM ([(String, EgisonExpr)], [EgisonTopExpr]) collectDefs (expr:exprs) bindings rest = case expr of - Define name expr -> collectDefs exprs ((name, expr) : bindings) rest + Define name expr -> collectDefs exprs ((show name, expr) : bindings) rest Load _ -> throwError $ strMsg "No IO support" LoadFile _ -> throwError $ strMsg "No IO support" _ -> collectDefs exprs bindings (expr : rest) @@ -138,7 +140,8 @@ return $ snd ret evalTopExpr' :: Env -> EgisonTopExpr -> EgisonM (Maybe String, Env) -evalTopExpr' env (Define name expr) = recursiveBind env [(name, expr)] >>= return . ((,) Nothing) +evalTopExpr' env (Define name expr) = recursiveBind env [(show name, expr)] >>= return . ((,) Nothing) +evalTopExpr' env (Redefine name expr) = recursiveRebind env (show name, expr) >>= return . ((,) Nothing) evalTopExpr' env (Test expr) = do val <- evalExprDeep env expr return (Just (show val), env) @@ -157,12 +160,26 @@ evalExpr _ (IntegerExpr x) = return . Value $ toEgison x evalExpr _ (FloatExpr x y) = return . Value $ Float x y +evalExpr env (QuoteExpr expr) = do + whnf <- evalExpr env expr + case whnf of + Value (ScalarData s) -> return . Value $ ScalarData $ Div (Plus [Term 1 [(Quote s, 1)]]) (Plus [Term 1 []]) + _ -> throwError $ TypeMismatch "scalar in quote" $ whnf + +evalExpr env (QuoteFunctionExpr expr) = do + whnf <- evalExpr env expr + case whnf of + Value val -> return . Value $ QuotedFunc val + _ -> throwError $ TypeMismatch "value in quote-function" $ whnf + evalExpr env (VarExpr name) = refVar' env name >>= evalRef where - refVar' :: Env -> Var -> EgisonM ObjectRef - refVar' env var = maybe (newEvalutedObjectRef (Value (symbolScalarData var []))) return + refVar' :: Env -> String -> EgisonM ObjectRef + refVar' env var = maybe (newEvaluatedObjectRef (Value (symbolScalarData "" var))) return (refVar env var) +evalExpr env (PartialVarExpr n) = evalExpr env (VarExpr ("::" ++ show n)) + evalExpr _ (InductiveDataExpr name []) = return . Value $ InductiveData name [] evalExpr env (InductiveDataExpr name exprs) = Intermediate . IInductiveData name <$> mapM (newObjectRef env) exprs @@ -186,33 +203,27 @@ refs' <- mapM (newObjectRef env) exprs return . Intermediate . IArray $ Array.listArray (1, toInteger (length exprs)) refs' -evalExpr env (TensorExpr nsExpr xsExpr) = do - nsWhnf <- evalExpr env nsExpr - ns <- ((fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer]) - xsWhnf <- evalExpr env xsExpr - xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef >>= mapM toScalarData - if product ns == toInteger (length xs) - then return $ Value $ TensorData (makeTensor ns xs Nothing) - else throwError $ InconsistentTensorSize - where - toScalarData :: WHNFData -> EgisonM ScalarData - toScalarData (Value (ScalarData x)) = return x - toScalarData val = throwError $ TypeMismatch "integer or string" $ val +evalExpr env (VectorExpr exprs) = do + whnfs <- mapM (evalExpr env) exprs + case whnfs of + [whnf] -> return $ whnf + ((Intermediate (ITensor (Tensor _ _ _))):_) -> do + mapM toTensor whnfs >>= tConcat' >>= fromTensor + _ -> do + fromTensor (Tensor [fromIntegral (length whnfs)] (V.fromList whnfs) []) -evalExpr env (InitTensorExpr nsExpr xsExpr jsExpr) = do +evalExpr env (TensorExpr nsExpr xsExpr supExpr subExpr) = do nsWhnf <- evalExpr env nsExpr ns <- ((fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer]) xsWhnf <- evalExpr env xsExpr - xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef >>= mapM toScalarData - jsWhnf <- evalExpr env jsExpr - js <- fromCollection jsWhnf >>= fromMList >>= mapM evalRef >>= mapM toScalarData + xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef + supWhnf <- evalExpr env supExpr + sup <- fromCollection supWhnf >>= fromMList >>= mapM evalRefDeep -- >>= mapM extractScalar' + subWhnf <- evalExpr env subExpr + sub <- fromCollection subWhnf >>= fromMList >>= mapM evalRefDeep -- >>= mapM extractScalar' if product ns == toInteger (length xs) - then return $ Value $ TensorData (makeTensor ns xs (Just js)) + then fromTensor (initTensor ns xs sup sub) else throwError $ InconsistentTensorSize - where - toScalarData :: WHNFData -> EgisonM ScalarData - toScalarData (Value (ScalarData x)) = return x - toScalarData val = throwError $ TypeMismatch "integer or string" $ val evalExpr env (HashExpr assocs) = do let (keyExprs, exprs) = unzip assocs @@ -245,30 +256,61 @@ makeHashKey whnf = throwError $ TypeMismatch "integer or string" $ whnf evalExpr env (IndexedExpr expr indices) = do - tensor <- evalExpr env expr - indices' <- mapM (evalExprDeep env) indices + tensor <- case expr of + (VarExpr var) -> do + let mObjRef = refVar env (show (Var var (map f indices))) + case mObjRef of + (Just objRef) -> evalRef objRef + Nothing -> evalExpr env expr + _ -> evalExpr env expr + js <- mapM (\i -> case i of + Superscript n -> evalExprDeep env n >>= return . Superscript + Subscript n -> evalExprDeep env n >>= return . Subscript + SupSubscript n -> evalExprDeep env n >>= return . SupSubscript + ) indices case tensor of - (Value (ScalarData (Div (Plus [(Term 1 [(Symbol name [], 1)])]) (Plus [(Term 1 [])])))) -> do - js <- (mapM fromEgison indices') :: EgisonM [Integer] - return $ Value (ScalarData (Div (Plus [(Term 1 [(Symbol name js, 1)])]) (Plus [(Term 1 [])]))) - (Value (TensorData (TData (Tensor ns xs) _))) -> do - indices'' <- mapM extract indices' - tCheckIndex indices'' ns - if all (\x -> isInteger x) indices' - then do indices'' <- ((mapM fromEgison indices') :: EgisonM [Integer]) - return $ Value $ ScalarData (tref' indices'' (Tensor ns xs)) - else do ret <- tContract (TData (tref indices'' (Tensor ns xs)) (Just (filter (isSymbol . ScalarData) indices''))) - return $ Value ret - _ -> refArray tensor indices' + (Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name [], 1)])]) (Plus [(Term 1 [])])))) -> do + js2 <- mapM (\i -> case i of + Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript + Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript + SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript + ) indices + return $ Value (ScalarData (Div (Plus [(Term 1 [(Symbol id name js2, 1)])]) (Plus [(Term 1 [])]))) + (Value (ScalarData _)) -> do + return $ tensor + (Value (TensorData (Tensor ns xs _))) -> do + tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor >>= return . Value + (Intermediate (ITensor (Tensor ns xs _))) -> do + tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor + _ -> do + js2 <- mapM (\i -> case i of + Superscript n -> evalExprDeep env n >>= extractScalar >>= return . Superscript + Subscript n -> evalExprDeep env n >>= extractScalar >>= return . Subscript + SupSubscript n -> evalExprDeep env n >>= extractScalar >>= return . SupSubscript + ) indices + refArray tensor (map (\j -> case j of + Superscript k -> ScalarData k + Subscript k -> ScalarData k + SupSubscript k -> ScalarData k + ) js2) where - extract :: EgisonValue -> EgisonM ScalarData - extract (ScalarData s) = return s - extract val = throwError $ TypeMismatch "scalar expression" (Value val) + f :: Index a -> Index () + f (Superscript _) = Superscript () + f (Subscript _) = Subscript () + f (SupSubscript _) = SupSubscript () -evalExpr env (LambdaExpr names expr) = return . Value $ Func Nothing env names expr +evalExpr env (LambdaExpr names expr) = do + names' <- mapM (\name -> case name of + (TensorArg name') -> return name' + (ScalarArg _) -> throwError $ EgisonBug "scalar-arg remained") names + return . Value $ Func Nothing env names' expr +evalExpr env (PartialExpr n expr) = return . Value $ PartialFunc env n expr + evalExpr env (CambdaExpr name expr) = return . Value $ CFunc Nothing env name expr +evalExpr env (ProcedureExpr names expr) = return . Value $ Proc Nothing env names expr + evalExpr env (MacroExpr names expr) = return . Value $ Macro names expr evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern @@ -306,6 +348,73 @@ genVar :: State Int String genVar = modify (1+) >> gets (('#':) . show) +evalExpr env (WithSymbolsExpr vars expr) = do + symId <- fresh + syms <- mapM (\var -> (newEvaluatedObjectRef (Value (symbolScalarData symId var)))) vars + let bindings = zip vars syms + whnf <- evalExpr (extendEnv env bindings) expr + case whnf of + (Value val) -> removeVarsFromIndices symId val >>= return . Value + (Intermediate (ITensor (Tensor ns xs js))) -> do + js' <- removeVars symId (tClearIndex' js) + return (Intermediate (ITensor (Tensor ns xs js'))) + _ -> return whnf + where + removeVarsFromIndices :: String -> EgisonValue -> EgisonM EgisonValue + removeVarsFromIndices symId (TensorData (Tensor ns xs js)) = do + xs' <- mapM (removeVarsFromIndices symId) xs + js' <- removeVars symId (tClearIndex' js) + fromTensor (Tensor ns xs' js') + removeVarsFromIndices symId (ScalarData s) = f symId s >>= return . ScalarData + removeVarsFromIndices _ val = return val + f :: String -> ScalarData -> EgisonM ScalarData + f symId (Div (Plus ts1) (Plus ts2)) = do + ts1' <- mapM (g symId) ts1 + ts2' <- mapM (g symId) ts2 + return (Div (Plus ts1') (Plus ts2')) + g :: String -> TermExpr -> EgisonM TermExpr + g symId (Term a xns) = do + let (xs, ns) = unzip xns + xs' <- mapM (h symId) xs + return (Term a (zip xs' ns)) + h :: String -> SymbolExpr -> EgisonM SymbolExpr + h symId (Symbol id name js) = do + js' <- removeVars symId (map (\j -> case j of + Superscript i -> Superscript (ScalarData i) + Subscript i -> Subscript (ScalarData i) + SupSubscript i -> SupSubscript (ScalarData i) + )js) + let js'' = map (\j -> case j of + Superscript (ScalarData i) -> Superscript i + Subscript (ScalarData i) -> Subscript i + SupSubscript (ScalarData i) -> SupSubscript i + ) js' + return (Symbol id name js'') + h symId (Apply fn xs) = do + xs' <- mapM (f symId) xs + return (Apply fn xs') + h symId (Quote x) = do + x' <- f symId x + return (Quote x') + removeVars :: String -> [Index EgisonValue] -> EgisonM [Index EgisonValue] + removeVars _ [] = return [] + removeVars symId ((Subscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js) + | symId == id = return [] + | otherwise = do js' <- removeVars symId js + return $ (Subscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js' + removeVars symId ((Superscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js) + | symId == id = return [] + | otherwise = do js' <- removeVars symId js + return $ (Superscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js' + removeVars symId ((SupSubscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js) + | symId == id = return [] + | otherwise = do js' <- removeVars symId js + return $ (SupSubscript (ScalarData (Div (Plus [Term 1 [(Symbol id name is,n)]]) (Plus [Term 1 []])))):js' + removeVars symId (j:js) = do + js' <- removeVars symId js + return $ j:js' + + evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do let body = foldr genLet (ApplyExpr expr $ TupleExpr [VarExpr "#1"]) bindings applyFunc env (Value $ Func Nothing env ["#1"] body) $ Value World @@ -324,7 +433,7 @@ _ -> throwError $ TypeMismatch "io" io evalExpr env (MatchAllExpr target matcher (pattern, expr)) = do - target <- newObjectRef env target + target <- evalExpr env target matcher <- evalExpr env matcher >>= evalMatcherWHNF result <- patternMatch env pattern target matcher mmap (flip evalExpr expr . extendEnv env) result >>= fromMList @@ -332,20 +441,23 @@ fromMList :: MList EgisonM WHNFData -> EgisonM WHNFData fromMList MNil = return . Value $ Collection Sq.empty fromMList (MCons val m) = do - head <- IElement <$> newEvalutedObjectRef val + head <- IElement <$> newEvaluatedObjectRef val tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList) seqRef <- liftIO . newIORef $ Sq.fromList [head, tail] return . Intermediate $ ICollection $ seqRef evalExpr env (MatchExpr target matcher clauses) = do - target <- newObjectRef env target + target <- evalExpr env target matcher <- evalExpr env matcher >>= evalMatcherWHNF - let tryMatchClause (pattern, expr) cont = do - result <- patternMatch env pattern target matcher - case result of - MCons bindings _ -> evalExpr (extendEnv env bindings) expr - MNil -> cont - foldr tryMatchClause (throwError $ strMsg "failed pattern match") clauses + f matcher target + where + f matcher target = do + let tryMatchClause (pattern, expr) cont = do + result <- patternMatch env pattern target matcher + case result of + MCons bindings _ -> evalExpr (extendEnv env bindings) expr + MNil -> cont + foldr tryMatchClause (throwError $ strMsg "failed pattern match") clauses evalExpr env (SeqExpr expr1 expr2) = do evalExprDeep env expr1 @@ -363,7 +475,7 @@ evalRef objRef Nothing -> do whnf <- applyFunc env (Value (Func Nothing env names body)) (Value (makeTuple args)) - retRef <- newEvalutedObjectRef whnf + retRef <- newEvaluatedObjectRef whnf hash <- liftIO $ readIORef hashRef liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) writeObjectRef ref (Value (MemoizedFunc name ref hashRef env names body)) @@ -374,6 +486,10 @@ func <- evalExpr env func arg <- evalExpr env arg case func of + Value (TensorData t@(Tensor ns fs js)) -> do + tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor >>= return . Value + Intermediate (ITensor t@(Tensor ns fs js)) -> do + tMap (\f -> applyFunc env f arg) t >>= fromTensor Value (MemoizedFunc name ref hashRef env names body) -> do indices <- evalWHNF arg indices' <- mapM fromEgison $ fromTupleValue indices @@ -383,7 +499,7 @@ evalRef objRef Nothing -> do whnf <- applyFunc env (Value (Func Nothing env names body)) arg - retRef <- newEvalutedObjectRef whnf + retRef <- newEvaluatedObjectRef whnf hash <- liftIO $ readIORef hashRef liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) writeObjectRef ref (Value (MemoizedFunc name ref hashRef env names body)) @@ -398,7 +514,7 @@ indices' <- mapM fromEgison $ fromTupleValue indices hash <- liftIO $ readIORef hashRef ret <- evalExprDeep env z - retRef <- newEvalutedObjectRef (Value ret) + retRef <- newEvaluatedObjectRef (Value ret) liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body)) _ -> throwError $ TypeMismatch "memoized-function" (Value x')) @@ -422,42 +538,78 @@ size'' <- collectionToList size' ns <- (mapM fromEgison size'') :: EgisonM [Integer] fn <- evalExpr env fnExpr - xs <- mapM (\ms -> applyFunc env fn (Value (makeTuple ms)) >>= evalWHNF >>= extractScalar) (map (\ms -> map toEgison ms) (tensorIndices ns)) - return $ Value (TensorData (makeTensor ns xs Nothing)) + xs <- mapM (\ms -> applyFunc env fn (Value (makeTuple ms))) (map (\ms -> map toEgison ms) (enumTensorIndices ns)) + case (ns, xs) of + ([1], x:[]) -> return $ x + _ -> fromTensor (Tensor ns (V.fromList xs) []) + +evalExpr env (TensorContractExpr fnExpr tExpr) = do + fn <- evalExpr env fnExpr + whnf <- evalExpr env tExpr + case whnf of + (Intermediate (ITensor t@(Tensor _ _ _))) -> do + ts <- tContract t + tMapN (\xs -> do xs' <- mapM newEvaluatedObjectRef xs + applyFunc env fn (Intermediate (ITuple xs'))) ts >>= fromTensor + (Value (TensorData t@(Tensor _ _ _))) -> do + ts <- tContract t + tMapN (\xs -> applyFunc' env fn (Tuple xs)) ts >>= fromTensor >>= return . Value + _ -> return whnf where - extractScalar :: EgisonValue -> EgisonM ScalarData - extractScalar (ScalarData x) = return x - extractScalar x = throwError $ TypeMismatch "scalar expression" (Value x) + applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue + applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF evalExpr env (TensorMapExpr fnExpr tExpr) = do fn <- evalExpr env fnExpr - tVal <- evalExpr env tExpr - case tVal of + whnf <- evalExpr env tExpr + case whnf of + Intermediate (ITensor t) -> do + tMap (applyFunc env fn) t >>= fromTensor Value (TensorData t) -> do - tMap (applyScalarFunc env fn) t >>= (return . Value . TensorData) - _ -> throwError $ TypeMismatch "tensor" tVal + tMap (applyFunc' env fn) t >>= fromTensor >>= return . Value + _ -> applyFunc env fn whnf where - applyScalarFunc :: Env -> WHNFData -> ScalarData -> EgisonM ScalarData - applyScalarFunc env fn s = applyFunc env fn (Value (ScalarData s)) >>= extractScalar - extractScalar :: WHNFData -> EgisonM ScalarData - extractScalar (Value (ScalarData x)) = return x - extractScalar x = throwError $ TypeMismatch "scalar expression" x + applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue + applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF evalExpr env (TensorMap2Expr fnExpr t1Expr t2Expr) = do fn <- evalExpr env fnExpr - t1Val <- evalExpr env t1Expr - t2Val <- evalExpr env t2Expr - case (t1Val, t2Val) of + whnf1 <- evalExpr env t1Expr + whnf2 <- evalExpr env t2Expr + case (whnf1, whnf2) of + -- both of arguments are tensors + (Intermediate (ITensor t1), Intermediate (ITensor t2)) -> do + tMap2 (applyFunc'' env fn) t1 t2 >>= fromTensor + (Intermediate (ITensor t), Value (TensorData (Tensor ns xs js))) -> do + let xs' = V.map Value xs + tMap2 (applyFunc'' env fn) t (Tensor ns xs' js) >>= fromTensor + (Value (TensorData (Tensor ns xs js)), Intermediate (ITensor t)) -> do + let xs' = V.map Value xs + tMap2 (applyFunc'' env fn) (Tensor ns xs' js) t >>= fromTensor (Value (TensorData t1), Value (TensorData t2)) -> do - tMap2 (applyScalarFunc env fn) t1 t2 >>= (return . Value . TensorData) - (Value (TensorData _), _) -> throwError $ TypeMismatch "tensor" t1Val - _ -> throwError $ TypeMismatch "tensor" t2Val + tMap2 (\x y -> applyFunc' env fn (Tuple [x, y])) t1 t2 >>= fromTensor >>= return . Value + -- an argument is scalar + (Intermediate (ITensor (Tensor ns xs js)), whnf) -> do + ys <- V.mapM (\x -> (applyFunc'' env fn x whnf)) xs + return $ Intermediate (ITensor (Tensor ns ys js)) + (whnf, Intermediate (ITensor (Tensor ns xs js))) -> do + ys <- V.mapM (\x -> (applyFunc'' env fn whnf x)) xs + return $ Intermediate (ITensor (Tensor ns ys js)) + (Value (TensorData (Tensor ns xs js)), whnf) -> do + ys <- V.mapM (\x -> (applyFunc'' env fn (Value x) whnf)) xs + return $ Intermediate (ITensor (Tensor ns ys js)) + (whnf, Value (TensorData (Tensor ns xs js))) -> do + ys <- V.mapM (\x -> (applyFunc'' env fn whnf (Value x))) xs + return $ Intermediate (ITensor (Tensor ns ys js)) + _ -> applyFunc'' env fn whnf1 whnf2 where - applyScalarFunc :: Env -> WHNFData -> ScalarData -> ScalarData -> EgisonM ScalarData - applyScalarFunc env fn s1 s2 = applyFunc env fn (Value (Tuple [(ScalarData s1), (ScalarData s2)])) >>= extractScalar - extractScalar :: WHNFData -> EgisonM ScalarData - extractScalar (Value (ScalarData x)) = return x - extractScalar x = throwError $ TypeMismatch "scalar expression" x + applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue + applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF + applyFunc'' :: Env -> WHNFData -> WHNFData -> WHNFData -> EgisonM WHNFData + applyFunc'' env fn x y = do + xRef <- newEvaluatedObjectRef x + yRef <- newEvaluatedObjectRef y + applyFunc env fn (Intermediate (ITuple [xRef, yRef])) evalExpr _ SomethingExpr = return $ Value Something evalExpr _ UndefinedExpr = return $ Value Undefined @@ -508,17 +660,33 @@ return $ StrHash refs' evalWHNF (Intermediate (ITuple [ref])) = evalRefDeep ref evalWHNF (Intermediate (ITuple refs)) = Tuple <$> mapM evalRefDeep refs +evalWHNF (Intermediate (ITensor (Tensor ns whnfs js))) = do + vals <- mapM evalWHNF whnfs + return $ TensorData $ Tensor ns vals js evalWHNF coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList) applyFunc :: Env -> WHNFData -> WHNFData -> EgisonM WHNFData +applyFunc _ (Value (PartialFunc env n body)) arg = do + refs <- fromTuple arg + if n == fromIntegral (length refs) + then evalExpr (extendEnv env $ makeBindings (map (\n -> "::" ++ show n) [1..n]) refs) body + else throwError $ ArgumentsNumWithNames ["partial"] (fromIntegral n) (length refs) applyFunc _ (Value (Func _ env [name] body)) arg = do - ref <- newEvalutedObjectRef arg + ref <- newEvaluatedObjectRef arg evalExpr (extendEnv env $ makeBindings [name] [ref]) body applyFunc _ (Value (Func _ env names body)) arg = do refs <- fromTuple arg if length names == length refs then evalExpr (extendEnv env $ makeBindings names refs) body else throwError $ ArgumentsNumWithNames names (length names) (length refs) +applyFunc _ (Value (Proc _ env [name] body)) arg = do + ref <- newEvaluatedObjectRef arg + evalExpr (extendEnv env $ makeBindings [name] [ref]) body +applyFunc _ (Value (Proc _ env names body)) arg = do + refs <- fromTuple arg + if length names == length refs + then evalExpr (extendEnv env $ makeBindings names refs) body + else throwError $ ArgumentsNumWithNames names (length names) (length refs) applyFunc _ (Value (CFunc _ env name body)) arg = do refs <- fromTuple arg seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs) @@ -527,7 +695,7 @@ then evalExpr (extendEnv env $ makeBindings [name] [col]) body else throwError $ ArgumentsNumWithNames [name] 1 0 applyFunc env (Value (Macro [name] body)) arg = do - ref <- newEvalutedObjectRef arg + ref <- newEvaluatedObjectRef arg evalExpr (extendEnv env $ makeBindings [name] [ref]) body applyFunc env (Value (Macro names body)) arg = do refs <- fromTuple arg @@ -539,14 +707,14 @@ case arg of Value World -> m _ -> throwError $ TypeMismatch "world" arg -applyFunc _ (Value fn@(ScalarData (Div (Plus [(Term 1 [(Symbol name [], 1)])]) (Plus [(Term 1 [])])))) arg = do +applyFunc _ (Value (QuotedFunc fn)) arg = do args <- tupleToList arg - mExprs <- mapM p args + mExprs <- mapM extractScalar args return (Value (ScalarData (Div (Plus [(Term 1 [(Apply fn mExprs, 1)])]) (Plus [(Term 1 [])])))) - where - p :: EgisonValue -> EgisonM ScalarData - p (ScalarData mExpr) = return mExpr - p val = throwError $ TypeMismatch "math expression" (Value val) +applyFunc _ (Value fn@(ScalarData (Div (Plus [(Term 1 [(Symbol _ _ _, 1)])]) (Plus [(Term 1 [])])))) arg = do + args <- tupleToList arg + mExprs <- mapM extractScalar args + return (Value (ScalarData (Div (Plus [(Term 1 [(Apply fn mExprs, 1)])]) (Plus [(Term 1 [])])))) applyFunc _ whnf _ = throwError $ TypeMismatch "function" whnf refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData @@ -558,10 +726,10 @@ then refArray (Value (array ! i)) indices else return $ Value Undefined else case index of - (ScalarData (Div (Plus [(Term 1 [(Symbol var [], 1)])]) (Plus [(Term 1 [])]))) -> do + (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ [], 1)])]) (Plus [(Term 1 [])]))) -> do let (_,size) = Array.bounds array elms <- mapM (\arr -> refArray (Value arr) indices) (Array.elems array) - elmRefs <- mapM newEvalutedObjectRef elms + elmRefs <- mapM newEvaluatedObjectRef elms return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs _ -> throwError $ TypeMismatch "integer or symbol" (Value index) refArray (Intermediate (IArray array)) (index:indices) = do @@ -572,12 +740,12 @@ evalRef ref >>= flip refArray indices else return $ Value Undefined else case index of - (ScalarData (Div (Plus [(Term 1 [(Symbol var [], 1)])]) (Plus [(Term 1 [])]))) -> do + (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ [], 1)])]) (Plus [(Term 1 [])]))) -> do let (_,size) = Array.bounds array let refs = Array.elems array arrs <- mapM evalRef refs elms <- mapM (\arr -> refArray arr indices) arrs - elmRefs <- mapM newEvalutedObjectRef elms + elmRefs <- mapM newEvaluatedObjectRef elms return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs _ -> throwError $ TypeMismatch "integer or symbol" (Value index) refArray (Value (IntHash hash)) (index:indices) = do @@ -629,8 +797,8 @@ writeObjectRef :: ObjectRef -> WHNFData -> EgisonM () writeObjectRef ref val = liftIO . writeIORef ref $ WHNF val -newEvalutedObjectRef :: WHNFData -> EgisonM ObjectRef -newEvalutedObjectRef = liftIO . newIORef . WHNF +newEvaluatedObjectRef :: WHNFData -> EgisonM ObjectRef +newEvaluatedObjectRef = liftIO . newIORef . WHNF makeBindings :: [String] -> [ObjectRef] -> [Binding] makeBindings = zip @@ -657,11 +825,30 @@ refs bindings return env' +recursiveRebind :: Env -> (String, EgisonExpr) -> EgisonM Env +recursiveRebind env (name, expr) = do + case refVar env name of + Nothing -> throwError $ UnboundVariable name + Just ref -> case expr of + MemoizedLambdaExpr names body -> do + hashRef <- liftIO $ newIORef HL.empty + liftIO . writeIORef ref . WHNF . Value $ MemoizedFunc (Just name) ref hashRef env names body + LambdaExpr args body -> do + whnf <- evalExpr env expr + case whnf of + (Value (Func _ env args body)) -> liftIO . writeIORef ref . WHNF $ (Value (Func (Just name) env args body)) + CambdaExpr arg body -> do + whnf <- evalExpr env expr + case whnf of + (Value (CFunc _ env arg body)) -> liftIO . writeIORef ref . WHNF $ (Value (CFunc (Just name) env arg body)) + _ -> liftIO . writeIORef ref . Thunk $ evalExpr env expr + return env + -- -- Pattern Match -- -patternMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher -> EgisonM (MList EgisonM Match) +patternMatch :: Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM (MList EgisonM Match) patternMatch env pattern target matcher = processMStates [msingleton $ MState env [] [] [MAtom pattern target matcher]] processMStates :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match) @@ -781,7 +968,7 @@ >>= (\b -> return $ msingleton $ MState env loops (b ++ bindings) ((MAtom pattern' target matcher):trees)) PredPat predicate -> do func <- evalExpr env' predicate - arg <- evalRef target + let arg = target result <- applyFunc env func arg >>= fromWHNF if result then return $ msingleton $ (MState env loops bindings trees) else return MNil @@ -796,26 +983,27 @@ DApplyPat func args -> do return $ msingleton $ (MState env loops bindings ((MAtom (InductivePat "apply" [func, (toListPat args)]) target matcher):trees)) - + LoopPat name (LoopRange start ends endPat) pat pat' -> do startNum <- evalExpr env' start >>= fromWHNF :: (EgisonM Integer) - startNumRef <- newEvalutedObjectRef $ Value $ toEgison (startNum - 1) + startNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum - 1) ends' <- evalExpr env' ends if isPrimitiveValue ends' then do - endsRef <- newEvalutedObjectRef ends' + endsRef <- newEvaluatedObjectRef ends' inners <- liftIO $ newIORef $ Sq.fromList [IElement endsRef] endsRef' <- liftIO $ newIORef (WHNF (Intermediate (ICollection inners))) return $ msingleton $ MState env ((LoopPatContext (name, startNumRef) endsRef' endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees) else do - endsRef <- newEvalutedObjectRef ends' + endsRef <- newEvaluatedObjectRef ends' return $ msingleton $ MState env ((LoopPatContext (name, startNumRef) endsRef endPat pat pat'):loops) bindings ((MAtom ContPat target matcher):trees) ContPat -> case loops of [] -> throwError $ strMsg "cannot use cont pattern except in loop pattern" LoopPatContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do - startNum <- evalRef startNumRef >>= fromWHNF :: (EgisonM Integer) - nextNumRef <- newEvalutedObjectRef $ Value $ toEgison (startNum + 1) + startNumWhnf <- evalRef startNumRef + startNum <- fromWHNF startNumWhnf :: (EgisonM Integer) + nextNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum + 1) ends <- evalRef endsRef b <- isEmptyCollection ends if b @@ -826,7 +1014,7 @@ if startNum > carEndsNum then return MNil else if startNum == carEndsNum - then return $ fromList [MState env loops' bindings ((MAtom endPat startNumRef Something):(MAtom pat' target matcher):trees), + then return $ fromList [MState env loops' bindings ((MAtom endPat startNumWhnf Something):(MAtom pat' target matcher):trees), MState env ((LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] else return $ fromList [MState env ((LoopPatContext (name, nextNumRef) endsRef endPat pat pat'):loops') bindings ((MAtom pat target matcher):trees)] AndPat patterns -> @@ -841,7 +1029,7 @@ UserMatcher _ _ _ -> do (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher mfor targetss $ \ref -> do - targets <- evalRef ref >>= fromTuple + targets <- evalRef ref >>= fromTupleWHNF let trees' = zipWith3 MAtom patterns targets matchers ++ trees return $ MState env loops bindings trees' @@ -852,7 +1040,7 @@ PatVar _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees) IndexedPat _ _ -> return $ msingleton $ MState env loops bindings ((MAtom pattern target Something):trees) TuplePat patterns -> do - targets <- evalRef target >>= fromTuple + targets <- fromTupleWHNF target if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return () if not (length patterns == length matchers) then throwError $ ArgumentsNum (length patterns) (length matchers) else return () let trees' = zipWith3 MAtom patterns targets matchers ++ trees @@ -863,32 +1051,35 @@ case pattern of ValuePat valExpr -> do val <- evalExprDeep env' valExpr - tgtVal <- evalRefDeep target + tgtVal <- evalWHNF target if val == tgtVal then return $ msingleton $ MState env loops bindings trees else return MNil WildCard -> return $ msingleton $ MState env loops bindings trees - PatVar name -> return $ msingleton $ MState env loops ((name, target):bindings) trees + PatVar name -> do + targetRef <- newEvaluatedObjectRef target + return $ msingleton $ MState env loops ((name, targetRef):bindings) trees IndexedPat (PatVar name) indices -> do indices <- mapM (evalExpr env' >=> liftM fromInteger . fromWHNF) indices case lookup name bindings of Just ref -> do - obj <- evalRef ref >>= updateHash indices >>= newEvalutedObjectRef + obj <- evalRef ref >>= updateHash indices >>= newEvaluatedObjectRef return $ msingleton $ MState env loops (subst name obj bindings) trees Nothing -> do - obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvalutedObjectRef + obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvaluatedObjectRef return $ msingleton $ MState env loops ((name,obj):bindings) trees where updateHash :: [Integer] -> WHNFData -> EgisonM WHNFData updateHash [index] (Intermediate (IIntHash hash)) = do - return . Intermediate . IIntHash $ HL.insert index target hash + targetRef <- newEvaluatedObjectRef target + return . Intermediate . IIntHash $ HL.insert index targetRef hash updateHash (index:indices) (Intermediate (IIntHash hash)) = do val <- maybe (return $ Intermediate $ IIntHash HL.empty) evalRef $ HL.lookup index hash - ref <- updateHash indices val >>= newEvalutedObjectRef + ref <- updateHash indices val >>= newEvaluatedObjectRef return . Intermediate . IIntHash $ HL.insert index ref hash updateHash indices (Value (IntHash hash)) = do keys <- return $ HL.keys hash - vals <- mapM (newEvalutedObjectRef . Value) $ HL.elems hash + vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash updateHash indices (Intermediate $ IIntHash $ HL.fromList $ zip keys vals) updateHash _ v = throwError $ strMsg $ "expected hash value: " ++ show v subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)] @@ -897,14 +1088,14 @@ subst _ _ [] = [] IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern) TuplePat patterns -> do - targets <- evalRef target >>= fromTuple + targets <- fromTupleWHNF target if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return () let trees' = zipWith3 MAtom patterns targets (take (length patterns) (repeat Something)) ++ trees return $ msingleton $ MState env loops bindings trees' _ -> throwError $ strMsg "something can only match with a pattern variable" _ -> throwError $ EgisonBug $ "should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern -inductiveMatch :: Env -> EgisonPattern -> ObjectRef -> Matcher -> +inductiveMatch :: Env -> EgisonPattern -> WHNFData -> Matcher -> EgisonM ([EgisonPattern], MList EgisonM ObjectRef, [Matcher]) inductiveMatch env pattern target (UserMatcher matcherEnv _ clauses) = do foldr tryPPMatchClause failPPPatternMatch clauses @@ -936,54 +1127,57 @@ ref <- lift $ newObjectRef env expr return ([], [(name, ref)]) primitivePatPatternMatch env (PPInductivePat name patterns) (InductivePat name' exprs) - | name == name' = + | name == name' && length patterns == length exprs = (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs | otherwise = matchFail primitivePatPatternMatch _ _ _ = matchFail -primitiveDataPatternMatch :: PrimitiveDataPattern -> ObjectRef -> MatchM [Binding] +primitiveDataPatternMatch :: PrimitiveDataPattern -> WHNFData -> MatchM [Binding] primitiveDataPatternMatch PDWildCard _ = return [] -primitiveDataPatternMatch (PDPatVar name) ref = return [(name, ref)] -primitiveDataPatternMatch (PDInductivePat name patterns) ref = do - whnf <- lift $ evalRef ref +primitiveDataPatternMatch (PDPatVar name) whnf = do + ref <- lift $ newEvaluatedObjectRef whnf + return [(name, ref)] +primitiveDataPatternMatch (PDInductivePat name patterns) whnf = do case whnf of - Intermediate (IInductiveData name' refs) | name == name' -> - concat <$> zipWithM primitiveDataPatternMatch patterns refs + Intermediate (IInductiveData name' refs) | name == name' -> do + whnfs <- lift $ mapM evalRef refs + concat <$> zipWithM primitiveDataPatternMatch patterns whnfs Value (InductiveData name' vals) | name == name' -> do - refs <- lift $ mapM (newEvalutedObjectRef . Value) vals - concat <$> zipWithM primitiveDataPatternMatch patterns refs + let whnfs = map Value vals + concat <$> zipWithM primitiveDataPatternMatch patterns whnfs _ -> matchFail -primitiveDataPatternMatch (PDTuplePat patterns) ref = do - whnf <- lift $ evalRef ref +primitiveDataPatternMatch (PDTuplePat patterns) whnf = do case whnf of - Intermediate (ITuple refs) -> - concat <$> zipWithM primitiveDataPatternMatch patterns refs + Intermediate (ITuple refs) -> do + whnfs <- lift $ mapM evalRef refs + concat <$> zipWithM primitiveDataPatternMatch patterns whnfs Value (Tuple vals) -> do - refs <- lift $ mapM (newEvalutedObjectRef . Value) vals - concat <$> zipWithM primitiveDataPatternMatch patterns refs + let whnfs = map Value vals + concat <$> zipWithM primitiveDataPatternMatch patterns whnfs _ -> matchFail -primitiveDataPatternMatch PDEmptyPat ref = do - whnf <- lift $ evalRef ref +primitiveDataPatternMatch PDEmptyPat whnf = do isEmpty <- lift $ isEmptyCollection whnf if isEmpty then return [] else matchFail -primitiveDataPatternMatch (PDConsPat pattern pattern') ref = do - whnf <- lift $ evalRef ref +primitiveDataPatternMatch (PDConsPat pattern pattern') whnf = do (head, tail) <- unconsCollection whnf - (++) <$> primitiveDataPatternMatch pattern head - <*> primitiveDataPatternMatch pattern' tail -primitiveDataPatternMatch (PDSnocPat pattern pattern') ref = do - whnf <- lift $ evalRef ref + head' <- lift $ evalRef head + tail' <- lift $ evalRef tail + (++) <$> primitiveDataPatternMatch pattern head' + <*> primitiveDataPatternMatch pattern' tail' +primitiveDataPatternMatch (PDSnocPat pattern pattern') whnf = do (init, last) <- unsnocCollection whnf - (++) <$> primitiveDataPatternMatch pattern init - <*> primitiveDataPatternMatch pattern' last -primitiveDataPatternMatch (PDConstantPat expr) ref = do - target <- lift (evalRef ref) >>= either (const matchFail) return . extractPrimitiveValue + init' <- lift $ evalRef init + last' <- lift $ evalRef last + (++) <$> primitiveDataPatternMatch pattern init' + <*> primitiveDataPatternMatch pattern' last' +primitiveDataPatternMatch (PDConstantPat expr) whnf = do + target <- (either (const matchFail) return . extractPrimitiveValue) whnf isEqual <- lift $ (==) <$> evalExprDeep nullEnv expr <*> pure target if isEqual then return [] else matchFail expandCollection :: WHNFData -> EgisonM (Seq Inner) expandCollection (Value (Collection vals)) = - mapM (liftM IElement . newEvalutedObjectRef . Value) vals + mapM (liftM IElement . newEvaluatedObjectRef . Value) vals expandCollection (Intermediate (ICollection innersRef)) = liftIO $ readIORef innersRef expandCollection val = throwError $ TypeMismatch "collection" val @@ -1005,15 +1199,15 @@ case Sq.viewl col of EmptyL -> matchFail val :< vals -> - lift $ (,) <$> newEvalutedObjectRef (Value val) - <*> newEvalutedObjectRef (Value $ Collection vals) + lift $ (,) <$> newEvaluatedObjectRef (Value val) + <*> newEvaluatedObjectRef (Value $ Collection vals) unconsCollection coll@(Intermediate (ICollection innersRef)) = do inners <- liftIO $ readIORef innersRef case Sq.viewl inners of EmptyL -> matchFail (IElement ref') :< tInners -> do tInnersRef <- liftIO $ newIORef tInners - lift $ (ref', ) <$> newEvalutedObjectRef (Intermediate $ ICollection tInnersRef) + lift $ (ref', ) <$> newEvaluatedObjectRef (Intermediate $ ICollection tInnersRef) (ISubCollection ref') :< tInners -> do hInners <- lift $ evalRef ref' >>= expandCollection liftIO $ writeIORef innersRef (hInners >< tInners) @@ -1025,15 +1219,15 @@ case Sq.viewr col of EmptyR -> matchFail vals :> val -> - lift $ (,) <$> newEvalutedObjectRef (Value $ Collection vals) - <*> newEvalutedObjectRef (Value val) + lift $ (,) <$> newEvaluatedObjectRef (Value $ Collection vals) + <*> newEvaluatedObjectRef (Value val) unsnocCollection coll@(Intermediate (ICollection innersRef)) = do inners <- liftIO $ readIORef innersRef case Sq.viewr inners of EmptyR -> matchFail hInners :> (IElement ref') -> do hInnersRef <- liftIO $ newIORef hInners - lift $ (, ref') <$> newEvalutedObjectRef (Intermediate $ ICollection hInnersRef) + lift $ (, ref') <$> newEvaluatedObjectRef (Intermediate $ ICollection hInnersRef) hInners :> (ISubCollection ref') -> do tInners <- lift $ evalRef ref' >>= expandCollection liftIO $ writeIORef innersRef (hInners >< tInners) @@ -1062,9 +1256,14 @@ fromTuple :: WHNFData -> EgisonM [ObjectRef] fromTuple (Intermediate (ITuple refs)) = return refs -fromTuple (Value (Tuple vals)) = mapM (newEvalutedObjectRef . Value) vals -fromTuple whnf = return <$> newEvalutedObjectRef whnf +fromTuple (Value (Tuple vals)) = mapM (newEvaluatedObjectRef . Value) vals +fromTuple whnf = return <$> newEvaluatedObjectRef whnf +fromTupleWHNF :: WHNFData -> EgisonM [WHNFData] +fromTupleWHNF (Intermediate (ITuple refs)) = mapM evalRef refs +fromTupleWHNF (Value (Tuple vals)) = return $ map Value vals +fromTupleWHNF whnf = return [whnf] + fromTupleValue :: EgisonValue -> [EgisonValue] fromTupleValue (Tuple vals) = vals fromTupleValue val = [val] @@ -1072,7 +1271,7 @@ fromCollection :: WHNFData -> EgisonM (MList EgisonM ObjectRef) fromCollection (Value (Collection vals)) = if Sq.null vals then return MNil - else fromSeq <$> mapM (newEvalutedObjectRef . Value) vals + else fromSeq <$> mapM (newEvaluatedObjectRef . Value) vals fromCollection whnf@(Intermediate (ICollection _)) = do isEmpty <- isEmptyCollection whnf if isEmpty @@ -1094,9 +1293,11 @@ collectionToList :: WHNFData -> EgisonM [EgisonValue] collectionToList whnf = do val <- evalWHNF whnf - return $ collectionToList' val + collectionToList' val where - collectionToList' (Collection sq) = toList sq + collectionToList' :: EgisonValue -> EgisonM [EgisonValue] + collectionToList' (Collection sq) = return $ toList sq + collectionToList' val = throwError $ TypeMismatch "collection" (Value val) makeTuple :: [EgisonValue] -> EgisonValue makeTuple [] = Tuple [] diff --git a/hs-src/Language/Egison/Desugar.hs b/hs-src/Language/Egison/Desugar.hs --- a/hs-src/Language/Egison/Desugar.hs +++ b/hs-src/Language/Egison/Desugar.hs @@ -22,6 +22,7 @@ import qualified Data.Sequence as Sq import Data.Sequence (ViewL(..), (<|)) import qualified Data.Set as S +import Data.List (span) import Data.Set (Set) import Data.Char (toUpper) import Control.Monad.Error @@ -40,6 +41,9 @@ desugarTopExpr (Define name expr) = do expr' <- liftEgisonM $ runDesugarM $ desugar expr return (Define name expr') +desugarTopExpr (Redefine name expr) = do + expr' <- liftEgisonM $ runDesugarM $ desugar expr + return (Redefine name expr') desugarTopExpr (Test expr) = do expr' <- liftEgisonM $ runDesugarM $ desugar expr return (Test expr') @@ -122,23 +126,19 @@ desugar (MatchAllLambdaExpr matcher clause) = do name <- fresh - matcher' <- desugar matcher - clause' <- desugarMatchClause clause - return $ LambdaExpr [name] (MatchAllExpr (VarExpr name) matcher' clause') + desugar $ LambdaExpr [TensorArg name] (MatchAllExpr (VarExpr name) matcher clause) desugar (MatchLambdaExpr matcher clauses) = do name <- fresh - matcher' <- desugar matcher - clauses' <- desugarMatchClauses clauses - return $ LambdaExpr [name] (MatchExpr (VarExpr name) matcher' clauses') + desugar $ LambdaExpr [TensorArg name] (MatchExpr (VarExpr name) matcher clauses) desugar (ArrayRefExpr expr nums) = case nums of - (TupleExpr nums') -> desugar $ IndexedExpr expr nums' - _ -> desugar $ IndexedExpr expr [nums] + (TupleExpr nums') -> desugar $ IndexedExpr expr (map Subscript nums') + _ -> desugar $ IndexedExpr expr [Subscript nums] desugar (IndexedExpr expr indices) = - IndexedExpr <$> desugar expr <*> (mapM desugar indices) + IndexedExpr <$> desugar expr <*> (mapM desugarIndex indices) desugar (PowerExpr expr1 expr2) = do expr1' <- desugar expr1 @@ -169,9 +169,32 @@ (CollectionExpr inners') <- desugar (CollectionExpr inners) return $ CollectionExpr (SubCollectionExpr sub':inners') +desugar (VectorExpr exprs) = do + exprs' <- mapM desugar exprs + return $ VectorExpr exprs' + +desugar (TensorExpr nsExpr xsExpr supExpr subExpr) = do + nsExpr' <- desugar nsExpr + xsExpr' <- desugar xsExpr + return $ TensorExpr nsExpr' xsExpr' supExpr subExpr + desugar (LambdaExpr names expr) = do - expr' <- desugar expr - return $ LambdaExpr names expr' + let (rtnames, rhnames) = span (\name -> case name of + TensorArg _ -> True + ScalarArg _ -> False) (reverse names) + case rhnames of + [] -> do expr' <- desugar expr + return $ LambdaExpr names expr' + (ScalarArg rhname:rhnames') -> do + let (rtnames2, rhnames2) = span (\name -> case name of + TensorArg _ -> True + ScalarArg _ -> False) rhnames' + case rhnames2 of + [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames) + (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (VarExpr rhname)) + (ScalarArg rhname2:rhnames2') -> + desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames) + (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (VarExpr rhname2) (VarExpr rhname)) desugar (MemoizedLambdaExpr names expr) = do expr' <- desugar expr @@ -190,6 +213,10 @@ expr' <- desugar expr return $ CambdaExpr name expr' +desugar (ProcedureExpr names expr) = do + expr' <- desugar expr + return $ ProcedureExpr names expr' + --desugar (MacroExpr names expr) = do -- expr' <- desugar expr -- return $ MacroExpr names expr' @@ -219,6 +246,10 @@ expr' <- desugar expr return $ foldr (\bind ret -> LetExpr [bind] ret) expr' binds' +desugar (WithSymbolsExpr vars expr) = do + expr' <- desugar expr + return $ WithSymbolsExpr vars expr' + desugar (MatchExpr expr0 expr1 clauses) = do expr0' <- desugar expr0 expr1' <- desugar expr1 @@ -256,6 +287,11 @@ sizeExpr' <- desugar sizeExpr return $ GenerateTensorExpr fnExpr' sizeExpr' +desugar (TensorContractExpr fnExpr tExpr) = do + fnExpr' <- desugar fnExpr + tExpr' <- desugar tExpr + return $ TensorContractExpr fnExpr' tExpr' + desugar (TensorMapExpr fnExpr tExpr) = do fnExpr' <- desugar fnExpr tExpr' <- desugar tExpr @@ -280,6 +316,10 @@ desugar (VarExpr name) = do asks $ maybe (VarExpr name) id . lookup name +desugar FreshVarExpr = do + id <- fresh + return (VarExpr (":::" ++ id)) + desugar (MatcherBFSExpr matcherInfo) = do matcherInfo' <- desugarMatcherInfo matcherInfo return $ MatcherBFSExpr matcherInfo' @@ -288,20 +328,27 @@ matcherInfo' <- desugarMatcherInfo matcherInfo return $ MatcherDFSExpr matcherInfo' -desugar (PartialVarExpr n) = return $ VarExpr $ "::" ++ show n - -desugar RecVarExpr = return $ VarExpr "::" +desugar (PartialVarExpr n) = return $ PartialVarExpr n desugar (PartialExpr n expr) = do expr' <- desugar expr - if n == 0 - then return $ LetRecExpr [(["::"], LambdaExpr [] expr')] (LambdaExpr [] expr') - else return $ LetRecExpr [(["::"], LambdaExpr (annonVars (fromIntegral n)) expr')] (LambdaExpr (annonVars (fromIntegral n)) expr') - where - annonVars n = take n $ map (((++) "::") . show) [1..] + return $ LetRecExpr [(["::0"], PartialExpr n expr')] (VarExpr "::0") +desugar (QuoteExpr expr) = do + expr' <- desugar expr + return $ QuoteExpr expr' + +desugar (QuoteFunctionExpr expr) = do + expr' <- desugar expr + return $ QuoteFunctionExpr expr' + desugar expr = return expr +desugarIndex :: Index EgisonExpr -> DesugarM (Index EgisonExpr) +desugarIndex (Superscript expr) = desugar expr >>= return . Superscript +desugarIndex (Subscript expr) = desugar expr >>= return . Subscript +desugarIndex (SupSubscript expr) = desugar expr >>= return . SupSubscript + desugarPattern :: EgisonPattern -> DesugarM EgisonPattern desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern where @@ -320,6 +367,10 @@ collectName (LetPat _ pattern) = collectName pattern collectName (IndexedPat (PatVar name) _) = S.singleton name collectName (OrPat patterns) = collectNames patterns + collectName (DivPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 + collectName (PlusPat patterns) = collectNames patterns + collectName (MultPat patterns) = collectNames patterns + collectName (PowerPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 collectName _ = S.empty makeBinding :: String -> BindingExpr @@ -343,6 +394,31 @@ desugarPattern' (DApplyPat pattern patterns) = DApplyPat <$> desugarPattern' pattern <*> mapM desugarPattern' patterns desugarPattern' (LoopPat name range pattern1 pattern2) = LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' (LetPat binds pattern) = LetPat <$> desugarBindings binds <*> desugarPattern' pattern +desugarPattern' (DivPat pattern1 pattern2) = do + pat1' <- desugarPattern' pattern1 + pat2' <- desugarPattern' pattern2 + return $ InductivePat "div" [pat1', pat2'] +desugarPattern' (PlusPat patterns) = do + pats' <- mapM desugarPattern' patterns + case (reverse pats') of + [] -> return $ InductivePat "plus" [ValuePat (IntegerExpr 0)] + lp:hps -> + return $ InductivePat "plus" [foldr (\p r -> InductivePat "cons" [p, r]) lp (reverse hps)] +desugarPattern' (MultPat (intPat:patterns)) = do + intPat' <- desugarPattern' intPat + pats' <- mapM desugarPattern' patterns + case (reverse pats') of + [] -> return $ InductivePat "mult" [intPat', ValuePat (IntegerExpr 1)] + lp:hps -> + return $ InductivePat "mult" [intPat', + foldr (\p r -> case p of + (PowerPat p1 p2) -> InductivePat "ncons" [p1, p2, r] + _ -> InductivePat "cons" [p, r]) + (case lp of + (PowerPat p1 p2) -> InductivePat "ncons" [p1, p2, ValuePat (IntegerExpr 1)] + _ -> lp) + (reverse hps)] +desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' pattern = return pattern desugarLoopRange :: LoopRange -> DesugarM LoopRange diff --git a/hs-src/Language/Egison/Parser.hs b/hs-src/Language/Egison/Parser.hs --- a/hs-src/Language/Egison/Parser.hs +++ b/hs-src/Language/Egison/Parser.hs @@ -126,6 +126,7 @@ topExpr :: Parser EgisonTopExpr topExpr = try (Test <$> expr) <|> try (parens (defineExpr + <|> redefineExpr <|> testExpr <|> executeExpr <|> loadFileExpr @@ -133,8 +134,11 @@ "top-level expression" defineExpr :: Parser EgisonTopExpr -defineExpr = keywordDefine >> Define <$> varName <*> expr +defineExpr = keywordDefine >> Define <$> varNameWithIndexType <*> expr +redefineExpr :: Parser EgisonTopExpr +redefineExpr = (keywordRedefine <|> keywordSet) >> Redefine <$> varNameWithIndexType <*> expr + testExpr :: Parser EgisonTopExpr testExpr = keywordTest >> Test <$> expr @@ -152,31 +156,36 @@ expr :: Parser EgisonExpr expr = P.lexeme lexer (do expr0 <- expr' - expr1 <- option expr0 $ PowerExpr expr0 <$> (try $ char '^' >> expr') - option expr1 $ IndexedExpr expr1 <$> many1 (try $ char '_' >> expr')) + expr1 <- option expr0 $ IndexedExpr expr0 <$> many1 (try (char '_' >> expr' >>= return . Subscript) <|> try (char '~' >> expr' >>= return . Superscript) <|> try (string "~_" >> expr' >>= return . SupSubscript)) + option expr1 $ PowerExpr expr1 <$> (try $ char '^' >> expr')) + expr' :: Parser EgisonExpr expr' = (try partialExpr <|> try constantExpr <|> try partialVarExpr - <|> recVarExpr + <|> try freshVarExpr <|> try varExpr <|> inductiveDataExpr <|> try arrayExpr - <|> try tensorExpr + <|> try vectorExpr <|> try tupleExpr <|> try hashExpr <|> collectionExpr + <|> quoteExpr + <|> quoteFunctionExpr <|> parens (ifExpr <|> lambdaExpr <|> memoizedLambdaExpr <|> memoizeExpr <|> cambdaExpr + <|> procedureExpr <|> macroExpr <|> patternFunctionExpr <|> letRecExpr <|> letExpr <|> letStarExpr + <|> withSymbolsExpr <|> doExpr <|> ioExpr <|> matchAllExpr @@ -198,7 +207,8 @@ <|> arrayBoundsExpr <|> arrayRefExpr <|> generateTensorExpr - <|> initTensorExpr + <|> tensorExpr + <|> tensorContractExpr <|> tensorMapExpr <|> tensorMap2Expr ) @@ -207,6 +217,9 @@ varExpr :: Parser EgisonExpr varExpr = VarExpr <$> ident +freshVarExpr :: Parser EgisonExpr +freshVarExpr = char '#' >> return FreshVarExpr + inductiveDataExpr :: Parser EgisonExpr inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy expr whiteSpace @@ -223,15 +236,15 @@ arrayExpr :: Parser EgisonExpr arrayExpr = between lp rp $ ArrayExpr <$> sepEndBy expr whiteSpace where - lp = P.lexeme lexer (string "[|") - rp = string "|]" - -tensorExpr :: Parser EgisonExpr -tensorExpr = between lp rp $ TensorExpr <$> expr <*> expr - where lp = P.lexeme lexer (string "(|") rp = string "|)" +vectorExpr :: Parser EgisonExpr +vectorExpr = between lp rp $ VectorExpr <$> sepEndBy expr whiteSpace + where + lp = P.lexeme lexer (string "[|") + rp = string "|]" + hashExpr :: Parser EgisonExpr hashExpr = between lp rp $ HashExpr <$> sepEndBy pairExpr whiteSpace where @@ -240,6 +253,12 @@ pairExpr :: Parser (EgisonExpr, EgisonExpr) pairExpr = brackets $ (,) <$> expr <*> expr +quoteExpr :: Parser EgisonExpr +quoteExpr = char '\'' >> QuoteExpr <$> expr + +quoteFunctionExpr :: Parser EgisonExpr +quoteFunctionExpr = char '`' >> QuoteFunctionExpr <$> expr + matchAllExpr :: Parser EgisonExpr matchAllExpr = keywordMatchAll >> MatchAllExpr <$> expr <*> expr <*> matchClause @@ -305,7 +324,7 @@ ppPatVar = reservedOp "$" *> pure PPPatVar ppValuePat :: Parser PrimitivePatPattern -ppValuePat = string ",$" >> PPValuePat <$> ident +ppValuePat = reservedOp ",$" >> PPValuePat <$> ident ppInductivePat :: Parser PrimitivePatPattern ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace) @@ -328,7 +347,7 @@ ifExpr = keywordIf >> IfExpr <$> expr <*> expr <*> expr lambdaExpr :: Parser EgisonExpr -lambdaExpr = keywordLambda >> LambdaExpr <$> varNames <*> expr +lambdaExpr = keywordLambda >> LambdaExpr <$> argNames <*> expr memoizedLambdaExpr :: Parser EgisonExpr memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <*> expr @@ -345,6 +364,9 @@ cambdaExpr :: Parser EgisonExpr cambdaExpr = keywordCambda >> CambdaExpr <$> varName <*> expr +procedureExpr :: Parser EgisonExpr +procedureExpr = keywordProcedure >> ProcedureExpr <$> varNames <*> expr + macroExpr :: Parser EgisonExpr macroExpr = keywordMacro >> MacroExpr <$> varNames <*> expr @@ -360,6 +382,9 @@ letStarExpr :: Parser EgisonExpr letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <*> expr +withSymbolsExpr :: Parser EgisonExpr +withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> (braces $ sepEndBy ident whiteSpace) <*> expr + doExpr :: Parser EgisonExpr doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr "return") (TupleExpr [])) expr @@ -384,15 +409,31 @@ varName :: Parser String varName = char '$' >> ident +varNameWithIndexType :: Parser Var +varNameWithIndexType = P.lexeme lexer (do + char '$' + name <- ident + is <- many indexType + return $ Var name is) + +indexType :: Parser (Index ()) +indexType = try (char '~' >> return (Superscript ())) + <|> try (char '_' >> return (Subscript ())) + +argNames :: Parser [Arg] +argNames = return <$> argName + <|> brackets (sepEndBy argName whiteSpace) + +argName :: Parser Arg +argName = try (char '$' >> ident >>= return . ScalarArg) + <|> try (char '%' >> ident >>= return . TensorArg) + ioExpr :: Parser EgisonExpr ioExpr = keywordIo >> IoExpr <$> expr seqExpr :: Parser EgisonExpr seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr -recVarExpr :: Parser EgisonExpr -recVarExpr = reservedOp "#" >> pure RecVarExpr - cApplyExpr :: Parser EgisonExpr cApplyExpr = (keywordCApply >> CApplyExpr <$> expr <*> expr) @@ -410,14 +451,14 @@ _ | all null vars -> let genVar = modify (1+) >> gets (VarExpr . (':':) . show) args' = evalState (mapM (either (const genVar) return) args) 0 - in return . LambdaExpr (annonVars $ length vars) . ApplyExpr func $ TupleExpr args' + in return . LambdaExpr (map ScalarArg (annonVars $ length vars)) . ApplyExpr func $ TupleExpr args' | all (not . null) vars -> let ns = Set.fromList $ map read vars n = Set.size ns in if Set.findMin ns == 1 && Set.findMax ns == n then let args' = map (either (VarExpr . (':':)) id) args - in return . LambdaExpr (annonVars n) . ApplyExpr func $ TupleExpr args' + in return . LambdaExpr (map ScalarArg (annonVars n)) . ApplyExpr func $ TupleExpr args' else fail "invalid partial application" | otherwise -> fail "invalid partial application" where @@ -439,7 +480,7 @@ algebraicDataMatcherExpr = keywordAlgebraicDataMatcher >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 inductivePat' whiteSpace) where - inductivePat' :: Parser (String, [EgisonExpr]) + inductivePat' :: Parser (String, [EgisonExpr]) inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace generateArrayExpr :: Parser EgisonExpr @@ -459,9 +500,12 @@ generateTensorExpr :: Parser EgisonExpr generateTensorExpr = keywordGenerateTensor >> GenerateTensorExpr <$> expr <*> expr -initTensorExpr :: Parser EgisonExpr -initTensorExpr = keywordInitTensor >> InitTensorExpr <$> expr <*> expr <*> expr +tensorExpr :: Parser EgisonExpr +tensorExpr = keywordTensor >> TensorExpr <$> expr <*> expr <*> option (CollectionExpr []) expr <*> option (CollectionExpr []) expr +tensorContractExpr :: Parser EgisonExpr +tensorContractExpr = keywordTensorContract >> TensorContractExpr <$> expr <*> expr + tensorMapExpr :: Parser EgisonExpr tensorMapExpr = keywordTensorMap >> TensorMapExpr <$> expr <*> expr @@ -480,7 +524,6 @@ <|> patVar <|> varPat <|> valuePat - <|> regexPat <|> predPat <|> notPat <|> tuplePat @@ -490,8 +533,12 @@ <|> orPat <|> loopPat <|> letPat + <|> try divPat + <|> try plusPat + <|> try multPat <|> try dApplyPat <|> try pApplyPat +-- <|> powerPat ) pattern'' :: Parser EgisonPattern @@ -511,17 +558,14 @@ valuePat :: Parser EgisonPattern valuePat = char ',' >> ValuePat <$> expr -regexPat :: Parser EgisonPattern -regexPat = reservedOp "~" >> RegexPat <$> expr - predPat :: Parser EgisonPattern -predPat = reservedOp "?" >> PredPat <$> expr +predPat = char '?' >> PredPat <$> expr letPat :: Parser EgisonPattern letPat = keywordLet >> LetPat <$> bindings <*> pattern notPat :: Parser EgisonPattern -notPat = reservedOp "!" >> NotPat <$> pattern +notPat = char '!' >> NotPat <$> pattern tuplePat :: Parser EgisonPattern tuplePat = brackets $ TuplePat <$> sepEndBy pattern whiteSpace @@ -557,14 +601,30 @@ return (LoopRange s e ep)) <|> (do s <- expr ep <- option WildCard pattern - return (LoopRange s (ApplyExpr (VarExpr "from") (ApplyExpr (VarExpr "-") (TupleExpr [s, (IntegerExpr 1)]))) ep))) + return (LoopRange s (ApplyExpr (VarExpr "from") (ApplyExpr (VarExpr "-'") (TupleExpr [s, (IntegerExpr 1)]))) ep))) +divPat :: Parser EgisonPattern +divPat = reservedOp "/" >> DivPat <$> pattern <*> pattern + +plusPat :: Parser EgisonPattern +plusPat = reservedOp "+" >> PlusPat <$> sepEndBy pattern whiteSpace + +multPat :: Parser EgisonPattern +multPat = reservedOp "*" >> MultPat <$> sepEndBy powerPat whiteSpace + +powerPat :: Parser EgisonPattern +powerPat = try (do pat1 <- pattern + char '^' + pat2 <- pattern + return $ PowerPat pat1 pat2) + <|> pattern + -- Constants constantExpr :: Parser EgisonExpr -constantExpr = charExpr - <|> stringExpr +constantExpr = stringExpr <|> boolExpr + <|> try charExpr <|> try floatExpr <|> try integerExpr <|> (keywordSomething *> pure SomethingExpr) @@ -625,7 +685,7 @@ P.LanguageDef { P.commentStart = "#|" , P.commentEnd = "|#" , P.commentLine = ";" - , P.identStart = letter <|> symbol1 + , P.identStart = letter <|> symbol1 <|> symbol0 , P.identLetter = letter <|> digit <|> symbol2 , P.opStart = symbol1 , P.opLetter = symbol1 @@ -634,7 +694,8 @@ , P.nestedComments = True , P.caseSensitive = True } -symbol1 = oneOf "+-*/=." +symbol0 = oneOf "^" +symbol1 = oneOf "+-*/=.∂∇" symbol2 = symbol1 <|> oneOf "'!?" lexer :: P.GenTokenParser String () Identity @@ -643,6 +704,8 @@ reservedKeywords :: [String] reservedKeywords = [ "define" + , "redefine" + , "set!" , "test" , "execute" , "load-file" @@ -655,11 +718,13 @@ , "memoized-lambda" , "memoize" , "cambda" + , "procedure" , "macro" , "pattern-function" , "letrec" , "let" , "let*" + , "with-symbols" , "loop" , "match-all" , "match" @@ -675,7 +740,8 @@ , "array-bounds" , "array-ref" , "generate-tensor" - , "init-tensor" + , "tensor" + , "contract" , "tensor-map" , "tensor-map2" , "something" @@ -684,15 +750,17 @@ reservedOperators :: [String] reservedOperators = [ "$" + , ",$" , "_" , "^" , "&" , "|" , "|*" - , "!" - , "," - , "~" - , "@" +-- , "'" +-- , "~" +-- , "!" +-- , "," +-- , "@" , "..."] reserved :: String -> Parser () @@ -702,6 +770,8 @@ reservedOp = P.reservedOp lexer keywordDefine = reserved "define" +keywordRedefine = reserved "redefine" +keywordSet = reserved "set!" keywordTest = reserved "test" keywordExecute = reserved "execute" keywordLoadFile = reserved "load-file" @@ -716,11 +786,13 @@ keywordMemoizedLambda = reserved "memoized-lambda" keywordMemoize = reserved "memoize" keywordCambda = reserved "cambda" +keywordProcedure = reserved "procedure" keywordMacro = reserved "macro" keywordPatternFunction = reserved "pattern-function" keywordLetRec = reserved "letrec" keywordLet = reserved "let" keywordLetStar = reserved "let*" +keywordWithSymbols = reserved "with-symbols" keywordLoop = reserved "loop" keywordCont = reserved "..." keywordMatchAll = reserved "match-all" @@ -743,7 +815,8 @@ keywordArrayBounds = reserved "array-bounds" keywordArrayRef = reserved "array-ref" keywordGenerateTensor = reserved "generate-tensor" -keywordInitTensor = reserved "init-tensor" +keywordTensor = reserved "tensor" +keywordTensorContract = reserved "contract" keywordTensorMap = reserved "tensor-map" keywordTensorMap2 = reserved "tensor-map2" @@ -768,8 +841,10 @@ stringLiteral :: Parser String stringLiteral = P.stringLiteral lexer +--charLiteral :: Parser Char +--charLiteral = P.charLiteral lexer charLiteral :: Parser Char -charLiteral = P.charLiteral lexer +charLiteral = string "c#" >> anyChar boolLiteral :: Parser Bool boolLiteral = char '#' >> (char 't' *> pure True <|> char 'f' *> pure False) diff --git a/hs-src/Language/Egison/Primitives.hs b/hs-src/Language/Egison/Primitives.hs --- a/hs-src/Language/Egison/Primitives.hs +++ b/hs-src/Language/Egison/Primitives.hs @@ -25,6 +25,7 @@ import System.Process import qualified Data.Sequence as Sq +import qualified Data.Vector as V import Data.Char (ord, chr) import qualified Data.Text as T @@ -65,23 +66,50 @@ {-# INLINE oneArg #-} oneArg :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc -oneArg f = \args -> do - args' <- evalWHNF args - f args' >>= return . Value +oneArg f = \arg -> do + arg' <- evalWHNF arg + case arg' of + (TensorData (Tensor ns ds js)) -> do + ds' <- mapM (\d -> f d) ds + fromTensor (Tensor ns ds' js) >>= return . Value + _ -> f arg' >>= return . Value +{-# INLINE oneArg' #-} +oneArg' :: (EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc +oneArg' f = \arg -> do + arg' <- evalWHNF arg + case arg' of + _ -> f arg' >>= return . Value + {-# INLINE twoArgs #-} twoArgs :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc twoArgs f = \args -> do args' <- tupleToList args case args' of + [(TensorData t1@(Tensor _ _ _)), (TensorData t2@(Tensor _ _ _))] -> do + tProduct f t1 t2 >>= fromTensor >>= return . Value + [(TensorData(Tensor ns ds js)), val] -> do + ds' <- mapM (\d -> f d val) ds + fromTensor (Tensor ns ds' js) >>= return . Value + [val, (TensorData (Tensor ns ds js))] -> do + ds' <- mapM (\d -> f val d) ds + fromTensor (Tensor ns ds' js) >>= return . Value [val, val'] -> f val val' >>= return . Value _ -> throwError $ ArgumentsNumPrimitive 2 $ length args' -{-# INLINE threeArgs #-} -threeArgs :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc -threeArgs f = \args -> do +{-# INLINE twoArgs' #-} +twoArgs' :: (EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc +twoArgs' f = \args -> do args' <- tupleToList args case args' of + [val, val'] -> f val val' >>= return . Value + _ -> throwError $ ArgumentsNumPrimitive 2 $ length args' + +{-# INLINE threeArgs' #-} +threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EgisonM EgisonValue) -> PrimitiveFunc +threeArgs' f = \args -> do + args' <- tupleToList args + case args' of [val, val', val''] -> f val val' val'' >>= return . Value _ -> throwError $ ArgumentsNumPrimitive 3 $ length args' @@ -108,6 +136,10 @@ , ("b.-'", minus) , ("b.*'", multiply) , ("b./'", divide) + , ("f.+", floatPlus) + , ("f.-", floatMinus) + , ("f.*", floatMult) + , ("f./", floatDivide) , ("numerator", numerator') , ("denominator", denominator') , ("from-math-expr", fromScalarData) @@ -150,11 +182,8 @@ , ("b.acosh", floatUnaryOp acosh) , ("b.atanh", floatUnaryOp atanh) - , ("b..", tensorProd) - , ("b..'", tensorProd) - , ("tensor-index", tensorIndex) - , ("tensor-size", tensorSize) - , ("tensor-to-list", tensorToList) + , ("tensor-size", tensorSize') + , ("tensor-to-list", tensorToList') , ("itof", integerToFloat) , ("rtof", rationalToFloat) @@ -170,6 +199,10 @@ , ("regex", regexString) , ("regex-cg", regexStringCaptureGroup) + , ("add-prime", addPrime) + , ("add-subscript", addSubscript) + , ("add-superscript", addSuperscript) + , ("read-process", readProcess') , ("read", read') @@ -184,7 +217,7 @@ , ("bool?", isBool') , ("integer?", isInteger') , ("rational?", isRational') - , ("number?", isNumber') + , ("scalar?", isScalar') , ("float?", isFloat') , ("char?", isChar') , ("string?", isString') @@ -247,46 +280,53 @@ f' <- fromEgison val' return $ Bool $ pred f f' +floatPlus :: PrimitiveFunc +floatPlus = twoArgs $ \val val' -> do + case (val, val') of + ((Float x y), (Float x' y')) -> return $ Float (x + x') (y + y') + _ -> throwError $ TypeMismatch "float" (Value val) + +floatMinus :: PrimitiveFunc +floatMinus = twoArgs $ \val val' -> do + case (val, val') of + ((Float x y), (Float x' y')) -> return $ Float (x - x') (y - y') + _ -> throwError $ TypeMismatch "float" (Value val) + +floatMult :: PrimitiveFunc +floatMult = twoArgs $ \val val' -> do + case (val, val') of + ((Float x y), (Float x' y')) -> return $ Float (x * x' - y * y') (x * y' + x' * y) + _ -> throwError $ TypeMismatch "float" (Value val) + +floatDivide :: PrimitiveFunc +floatDivide = twoArgs $ \val val' -> do + case (val, val') of + ((Float x y), (Float x' y')) -> return $ Float ((x * x' + y * y') / (x' * x' + y' * y')) ((y * x' - x * y') / (x' * x' + y' * y')) + _ -> throwError $ TypeMismatch "float" (Value val) + + -- -- Arith -- -numberUnaryOp :: (ScalarData -> ScalarData) -> (EgisonValue -> EgisonValue) -> PrimitiveFunc -numberUnaryOp mOp fOp arg = do - arg' <- tupleToList arg - case arg' of - [val] -> numberUnaryOp' val >>= return . Value - _ -> throwError $ ArgumentsNumPrimitive 1 $ length arg' - where - numberUnaryOp' f@(Float _ _) = return $ fOp f - numberUnaryOp' (ScalarData m) = (return . ScalarData . mathNormalize') (mOp m) - numberUnaryOp' val = throwError $ TypeMismatch "number" (Value val) - -numberBinaryOp :: (ScalarData -> ScalarData -> ScalarData) -> (EgisonValue -> EgisonValue -> EgisonValue) -> PrimitiveFunc -numberBinaryOp mOp fOp args = do - args' <- tupleToList args - case args' of - [val, val'] -> numberBinaryOp' val val' >>= return . Value - _ -> throwError $ ArgumentsNumPrimitive 2 $ length args' +scalarBinaryOp :: (ScalarData -> ScalarData -> ScalarData) -> PrimitiveFunc +scalarBinaryOp mOp = twoArgs $ \val val' -> do + scalarBinaryOp' val val' where - numberBinaryOp' f@(Float _ _) f'@(Float _ _) = return $ fOp f f' - numberBinaryOp' val (Float x' y') = numberBinaryOp' (numberToFloat' val) (Float x' y') - numberBinaryOp' (Float x y) val' = numberBinaryOp' (Float x y) (numberToFloat' val') - numberBinaryOp' (ScalarData m1) (ScalarData m2) = (return . ScalarData . mathNormalize') (mOp m1 m2) - numberBinaryOp' (ScalarData _) val' = throwError $ TypeMismatch "number" (Value val') - numberBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) + scalarBinaryOp' (ScalarData m1) (ScalarData m2) = (return . ScalarData . mathNormalize') (mOp m1 m2) + scalarBinaryOp' val _ = throwError $ TypeMismatch "number" (Value val) plus :: PrimitiveFunc -plus = numberBinaryOp mathPlus (\(Float x y) (Float x' y') -> Float (x + x') (y + y')) +plus = scalarBinaryOp mathPlus minus :: PrimitiveFunc -minus = numberBinaryOp (\m1 m2 -> mathPlus m1 (mathNegate m2)) (\(Float x y) (Float x' y') -> Float (x - x') (y - y')) +minus = scalarBinaryOp (\m1 m2 -> mathPlus m1 (mathNegate m2)) multiply :: PrimitiveFunc -multiply = numberBinaryOp mathMult (\(Float x y) (Float x' y') -> Float (x * x' - y * y') (x * y' + x' * y)) +multiply = scalarBinaryOp mathMult divide :: PrimitiveFunc -divide = numberBinaryOp (\m1 (Div p1 p2) -> mathMult m1 (Div p2 p1)) (\(Float x y) (Float x' y') -> Float ((x * x' + y * y') / (x' * x' + y' * y')) ((y * x' - x * y') / (x' * x' + y' * y'))) +divide = scalarBinaryOp (\m1 (Div p1 p2) -> mathMult m1 (Div p2 p1)) numerator' :: PrimitiveFunc numerator' = oneArg $ numerator'' @@ -319,52 +359,52 @@ return $ Bool $ val == val' lt :: PrimitiveFunc -lt = twoArgs $ \val val' -> numberBinaryPred' val val' +lt = twoArgs $ \val val' -> scalarBinaryPred' val val' where - numberBinaryPred' m@(ScalarData _) n@(ScalarData _) = do + scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do r <- fromEgison m :: EgisonM Rational r' <- fromEgison n :: EgisonM Rational return $ Bool $ (<) r r' - numberBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<) f f' - numberBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) - numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) + scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<) f f' + scalarBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val) + scalarBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) + scalarBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) lte :: PrimitiveFunc -lte = twoArgs $ \val val' -> numberBinaryPred' val val' +lte = twoArgs $ \val val' -> scalarBinaryPred' val val' where - numberBinaryPred' m@(ScalarData _) n@(ScalarData _) = do + scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do r <- fromEgison m :: EgisonM Rational r' <- fromEgison n :: EgisonM Rational return $ Bool $ (<=) r r' - numberBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<=) f f' - numberBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) - numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) + scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (<=) f f' + scalarBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val) + scalarBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) + scalarBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) gt :: PrimitiveFunc -gt = twoArgs $ \val val' -> numberBinaryPred' val val' +gt = twoArgs $ \val val' -> scalarBinaryPred' val val' where - numberBinaryPred' m@(ScalarData _) n@(ScalarData _) = do + scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do r <- fromEgison m :: EgisonM Rational r' <- fromEgison n :: EgisonM Rational return $ Bool $ (>) r r' - numberBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>) f f' - numberBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) - numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) + scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>) f f' + scalarBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val) + scalarBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) + scalarBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) gte :: PrimitiveFunc -gte = twoArgs $ \val val' -> numberBinaryPred' val val' +gte = twoArgs $ \val val' -> scalarBinaryPred' val val' where - numberBinaryPred' m@(ScalarData _) n@(ScalarData _) = do + scalarBinaryPred' m@(ScalarData _) n@(ScalarData _) = do r <- fromEgison m :: EgisonM Rational r' <- fromEgison n :: EgisonM Rational return $ Bool $ (>=) r r' - numberBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>=) f f' - numberBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val) - numberBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) - numberBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) + scalarBinaryPred' (Float f 0) (Float f' 0) = return $ Bool $ (>=) f f' + scalarBinaryPred' (ScalarData _) val = throwError $ TypeMismatch "number" (Value val) + scalarBinaryPred' (Float _ _) val = throwError $ TypeMismatch "float" (Value val) + scalarBinaryPred' val _ = throwError $ TypeMismatch "number" (Value val) truncate' :: PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val @@ -390,35 +430,17 @@ -- Tensor -- -tensorProd :: PrimitiveFunc -tensorProd = twoArgs $ tensorProd' - where - tensorProd' (TensorData (TData (Tensor ns1 xs1) (Just ms1))) - (TensorData (TData (Tensor ns2 xs2) (Just ms2))) = do - ret <- tContract (TData (Tensor (ns1 ++ ns2) (map (\is -> let is1 = take (length ns1) is in - let is2 = take (length ns2) (drop (length ns1) is) in - (mathMult (tref' is1 (Tensor ns1 xs1)) (tref' is2 (Tensor ns2 xs2))) - ) (tensorIndices (ns1 ++ ns2)))) (Just (ms1 ++ ms2))) - return ret - tensorProd' val1 val2 = throwError $ TypeMismatch "tensor data with index" (Value (Tuple [val1, val2])) - -tensorIndex :: PrimitiveFunc -tensorIndex = oneArg $ tensorIndex' - where - tensorIndex' (TensorData (TData (Tensor _ _) (Just ms))) = return . Collection . Sq.fromList $ map ScalarData ms - tensorIndex' val = throwError $ TypeMismatch "tensor with index" (Value val) - -tensorSize :: PrimitiveFunc -tensorSize = oneArg $ tensorSize' +tensorSize' :: PrimitiveFunc +tensorSize' = oneArg' $ tensorSize'' where - tensorSize' (TensorData (TData (Tensor ns _) _)) = return . Collection . Sq.fromList $ map toEgison ns - tensorSize' val = throwError $ TypeMismatch "tensor data" (Value val) + tensorSize'' (TensorData (Tensor ns _ _)) = return . Collection . Sq.fromList $ map toEgison ns + tensorSize'' _ = return . Collection $ Sq.fromList $ [toEgison (1 :: Integer)] -tensorToList :: PrimitiveFunc -tensorToList = oneArg $ tensorToList' +tensorToList' :: PrimitiveFunc +tensorToList' = oneArg' $ tensorToList'' where - tensorToList' (TensorData (TData (Tensor _ xs) _)) = return . Collection . Sq.fromList $ map ScalarData xs - tensorToList' val = throwError $ TypeMismatch "tensor data" (Value val) + tensorToList'' (TensorData (Tensor _ xs _)) = return . Collection . Sq.fromList $ V.toList xs + tensorToList'' x = return . Collection $ Sq.fromList $ [x] -- -- Transform @@ -530,8 +552,36 @@ -- (String _, _) -> throwError $ TypeMismatch "string" (Value src) -- (_, _) -> throwError $ TypeMismatch "string" (Value pat) +addPrime :: PrimitiveFunc +addPrime = oneArg $ \sym -> do + case sym of + ScalarData (Div (Plus [(Term 1 [(Symbol id name is, 1)])]) (Plus [(Term 1 [])])) -> return (ScalarData (Div (Plus [(Term 1 [(Symbol id (name ++ "'") is, 1)])]) (Plus [(Term 1 [])]))) + _ -> throwError $ TypeMismatch "symbol" (Value sym) + +addSubscript :: PrimitiveFunc +addSubscript = twoArgs $ \fn sub -> do + case (fn, sub) of + (ScalarData (Div (Plus [(Term 1 [(Symbol id name is, 1)])]) (Plus [(Term 1 [])])), + ScalarData s@(Div (Plus [(Term 1 [(Symbol _ _ [], 1)])]) (Plus [(Term 1 [])]))) -> return (ScalarData (Div (Plus [(Term 1 [(Symbol id name (is ++ [Subscript s]), 1)])]) (Plus [(Term 1 [])]))) + (ScalarData (Div (Plus [(Term 1 [(Symbol id name is, 1)])]) (Plus [(Term 1 [])])), + ScalarData s@(Div (Plus [(Term _ [])]) (Plus [(Term 1 [])]))) -> return (ScalarData (Div (Plus [(Term 1 [(Symbol id name (is ++ [Subscript s]), 1)])]) (Plus [(Term 1 [])]))) + (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ _, 1)])]) (Plus [(Term 1 [])])), + _) -> throwError $ TypeMismatch "symbol or integer" (Value sub) + _ -> throwError $ TypeMismatch "symbol or integer" (Value fn) + +addSuperscript :: PrimitiveFunc +addSuperscript = twoArgs $ \fn sub -> do + case (fn, sub) of + (ScalarData (Div (Plus [(Term 1 [(Symbol id name is, 1)])]) (Plus [(Term 1 [])])), + ScalarData s@(Div (Plus [(Term 1 [(Symbol _ _ [], 1)])]) (Plus [(Term 1 [])]))) -> return (ScalarData (Div (Plus [(Term 1 [(Symbol id name (is ++ [Superscript s]), 1)])]) (Plus [(Term 1 [])]))) + (ScalarData (Div (Plus [(Term 1 [(Symbol id name is, 1)])]) (Plus [(Term 1 [])])), + ScalarData s@(Div (Plus [(Term _ [])]) (Plus [(Term 1 [])]))) -> return (ScalarData (Div (Plus [(Term 1 [(Symbol id name (is ++ [Superscript s]), 1)])]) (Plus [(Term 1 [])]))) + (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ _, 1)])]) (Plus [(Term 1 [])])), + _) -> throwError $ TypeMismatch "symbol" (Value sub) + _ -> throwError $ TypeMismatch "symbol" (Value fn) + readProcess' :: PrimitiveFunc -readProcess' = threeArgs $ \cmd args input -> do +readProcess' = threeArgs' $ \cmd args input -> do case (cmd, args, input) of (String cmdStr, Collection argStrs, String inputStr) -> do outputStr <- liftIO $ readProcess (T.unpack cmdStr) (map (\arg -> case arg of @@ -541,19 +591,19 @@ (_, _, _) -> throwError $ TypeMismatch "(string, collection, string)" (Value (Tuple [cmd, args, input])) read' :: PrimitiveFunc -read'= oneArg $ \val -> fromEgison val >>= readExpr . T.unpack >>= evalExprDeep nullEnv +read'= oneArg' $ \val -> fromEgison val >>= readExpr . T.unpack >>= evalExprDeep nullEnv readTSV :: PrimitiveFunc -readTSV= oneArg $ \val -> do rets <- fromEgison val >>= readExprs . T.unpack >>= mapM (evalExprDeep nullEnv) - case rets of - [ret] -> return ret - _ -> return (Tuple rets) +readTSV= oneArg' $ \val -> do rets <- fromEgison val >>= readExprs . T.unpack >>= mapM (evalExprDeep nullEnv) + case rets of + [ret] -> return ret + _ -> return (Tuple rets) show' :: PrimitiveFunc -show'= oneArg $ \val -> return $ toEgison $ T.pack $ show val +show'= oneArg' $ \val -> return $ toEgison $ T.pack $ show val showTSV' :: PrimitiveFunc -showTSV'= oneArg $ \val -> return $ toEgison $ T.pack $ showTSV val +showTSV'= oneArg' $ \val -> return $ toEgison $ T.pack $ showTSV val -- -- Collection @@ -582,14 +632,14 @@ -- Test assert :: PrimitiveFunc -assert = twoArgs $ \label test -> do +assert = twoArgs' $ \label test -> do test <- fromEgison test if test then return $ Bool True else throwError $ Assertion $ show label assertEqual :: PrimitiveFunc -assertEqual = threeArgs $ \label actual expected -> do +assertEqual = threeArgs' $ \label actual expected -> do if actual == expected then return $ Bool True else throwError $ Assertion $ show label ++ "\n expected: " ++ show expected ++ @@ -633,37 +683,37 @@ makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []]) return' :: PrimitiveFunc -return' = oneArg $ \val -> return $ makeIO $ return val +return' = oneArg' $ \val -> return $ makeIO $ return val makePort :: IOMode -> PrimitiveFunc -makePort mode = oneArg $ \val -> do +makePort mode = oneArg' $ \val -> do filename <- fromEgison val port <- liftIO $ openFile (T.unpack filename) mode return $ makeIO $ return (Port port) closePort :: PrimitiveFunc -closePort = oneArg $ \val -> do +closePort = oneArg' $ \val -> do port <- fromEgison val return $ makeIO' $ liftIO $ hClose port writeChar :: PrimitiveFunc -writeChar = oneArg $ \val -> do +writeChar = oneArg' $ \val -> do c <- fromEgison val return $ makeIO' $ liftIO $ putChar c writeCharToPort :: PrimitiveFunc -writeCharToPort = twoArgs $ \val val' -> do +writeCharToPort = twoArgs' $ \val val' -> do port <- fromEgison val c <- fromEgison val' return $ makeIO' $ liftIO $ hPutChar port c writeString :: PrimitiveFunc -writeString = oneArg $ \val -> do +writeString = oneArg' $ \val -> do s <- fromEgison val return $ makeIO' $ liftIO $ T.putStr s writeStringToPort :: PrimitiveFunc -writeStringToPort = twoArgs $ \val val' -> do +writeStringToPort = twoArgs' $ \val val' -> do port <- fromEgison val s <- fromEgison val' return $ makeIO' $ liftIO $ T.hPutStr port s @@ -672,7 +722,7 @@ flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout flushPort :: PrimitiveFunc -flushPort = oneArg $ \val -> do +flushPort = oneArg' $ \val -> do port <- fromEgison val return $ makeIO' $ liftIO $ hFlush port @@ -680,7 +730,7 @@ readChar = noArg $ return $ makeIO $ liftIO $ liftM Char getChar readCharFromPort :: PrimitiveFunc -readCharFromPort = oneArg $ \val -> do +readCharFromPort = oneArg' $ \val -> do port <- fromEgison val c <- liftIO $ hGetChar port return $ makeIO $ return (Char c) @@ -689,13 +739,13 @@ readLine = noArg $ return $ makeIO $ liftIO $ liftM toEgison T.getLine readLineFromPort :: PrimitiveFunc -readLineFromPort = oneArg $ \val -> do +readLineFromPort = oneArg' $ \val -> do port <- fromEgison val s <- liftIO $ T.hGetLine port return $ makeIO $ return $ toEgison s readFile' :: PrimitiveFunc -readFile' = oneArg $ \val -> do +readFile' = oneArg' $ \val -> do filename <- fromEgison val s <- liftIO $ T.readFile $ T.unpack filename return $ makeIO $ return $ toEgison s @@ -704,13 +754,13 @@ isEOFStdin = noArg $ return $ makeIO $ liftIO $ liftM Bool isEOF isEOFPort :: PrimitiveFunc -isEOFPort = oneArg $ \val -> do +isEOFPort = oneArg' $ \val -> do port <- fromEgison val b <- liftIO $ hIsEOF port return $ makeIO $ return (Bool b) randRange :: PrimitiveFunc -randRange = twoArgs $ \val val' -> do +randRange = twoArgs' $ \val val' -> do i <- fromEgison val :: EgisonM Integer i' <- fromEgison val' :: EgisonM Integer n <- liftIO $ getStdRandom $ randomR (i, i') @@ -718,7 +768,7 @@ {-- -- for 'egison-sqlite' sqlite :: PrimitiveFunc -sqlite = twoArgs $ \val val' -> do +sqlite = twoArgs' $ \val val' -> do dbName <- fromEgison val qStr <- fromEgison val' ret <- liftIO $ query' (T.pack dbName) $ T.pack qStr diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs --- a/hs-src/Language/Egison/Types.hs +++ b/hs-src/Language/Egison/Types.hs @@ -15,6 +15,8 @@ EgisonTopExpr (..) , EgisonExpr (..) , EgisonPattern (..) + , Arg (..) + , Index (..) , InnerExpr (..) , BindingExpr (..) , MatchClause (..) @@ -22,27 +24,37 @@ , LoopRange (..) , PrimitivePatPattern (..) , PrimitiveDataPattern (..) + , Matcher (..) + , PrimitiveFunc (..) + , EgisonData (..) + , showTSV -- * Egison values , EgisonValue (..) , ScalarData (..) , PolyExpr (..) , TermExpr (..) , SymbolExpr (..) - , TensorData (..) , Tensor (..) - , scalarToUnitTensor - , scalarToTensor - , tMap - , tMap2 - , tCheckIndex - , tContract - , tref - , tref' + , HasTensor (..) + -- * Tensor + , initTensor , tSize , tToList , tIndex - , makeTensor - , tensorIndices + , tref + , enumTensorIndices + , tMap + , tMap2 + , tMapN + , tSum + , tProduct + , tContract + , tContract' + , tConcat + , tConcat' + , tClearIndex + , tClearIndex' + -- * Scalar , symbolScalarData , mathExprToEgison , egisonToScalarData @@ -51,17 +63,14 @@ , mathSymbolFold , mathTermFold , mathRemoveZero - , mathReduceFraction - , mathReduceSymbolFraction + , mathDivide , mathPlus , mathMult , mathNegate , mathNumerator , mathDenominator - , Matcher (..) - , PrimitiveFunc (..) - , EgisonData (..) - , showTSV + , extractScalar + , extractScalar' -- * Internal data , Object (..) , ObjectRef (..) @@ -113,13 +122,13 @@ , isInteger , isRational , isSymbol - , isNumber + , isScalar , isTensor , isTensorWithIndex , isBool' , isInteger' , isRational' - , isNumber' + , isScalar' , isFloat' , isComplex' , isTensor' @@ -147,6 +156,7 @@ import Data.Monoid (Monoid) import qualified Data.HashMap.Lazy as HL import qualified Data.Array as Array +import qualified Data.Vector as V import qualified Data.Sequence as Sq import Data.Sequence (Seq) import Data.Foldable (foldr, toList) @@ -154,7 +164,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List (intercalate, sort, sortBy) +import Data.List (intercalate, sort, sortBy, findIndex, splitAt, (\\), elem, delete, deleteBy, any) import Data.Text (Text) import qualified Data.Text as T @@ -169,7 +179,8 @@ -- data EgisonTopExpr = - Define String EgisonExpr + Define Var EgisonExpr + | Redefine Var EgisonExpr | Test EgisonExpr | Execute EgisonExpr -- temporary : we will replace load to import and export @@ -184,19 +195,21 @@ | IntegerExpr Integer | FloatExpr Double Double | VarExpr String - | IndexedExpr EgisonExpr [EgisonExpr] + | FreshVarExpr + | IndexedExpr EgisonExpr [Index EgisonExpr] | PowerExpr EgisonExpr EgisonExpr | InductiveDataExpr String [EgisonExpr] | TupleExpr [EgisonExpr] | CollectionExpr [InnerExpr] | ArrayExpr [EgisonExpr] | HashExpr [(EgisonExpr, EgisonExpr)] - | TensorExpr EgisonExpr EgisonExpr + | VectorExpr [EgisonExpr] - | LambdaExpr [String] EgisonExpr + | LambdaExpr [Arg] EgisonExpr | MemoizedLambdaExpr [String] EgisonExpr | MemoizeExpr [(EgisonExpr, EgisonExpr, EgisonExpr)] EgisonExpr | CambdaExpr String EgisonExpr + | ProcedureExpr [String] EgisonExpr | MacroExpr [String] EgisonExpr | PatternFunctionExpr [String] EgisonPattern @@ -204,6 +217,7 @@ | LetRecExpr [BindingExpr] EgisonExpr | LetExpr [BindingExpr] EgisonExpr | LetStarExpr [BindingExpr] EgisonExpr + | WithSymbolsExpr [String] EgisonExpr | MatchExpr EgisonExpr EgisonExpr [MatchClause] | MatchAllExpr EgisonExpr EgisonExpr MatchClause @@ -218,6 +232,9 @@ | MatcherBFSExpr MatcherInfo | MatcherDFSExpr MatcherInfo | AlgebraicDataMatcherExpr [(String, [EgisonExpr])] + + | QuoteExpr EgisonExpr + | QuoteFunctionExpr EgisonExpr | DoExpr [BindingExpr] EgisonExpr | IoExpr EgisonExpr @@ -234,14 +251,26 @@ | ArrayRefExpr EgisonExpr EgisonExpr | GenerateTensorExpr EgisonExpr EgisonExpr - | InitTensorExpr EgisonExpr EgisonExpr EgisonExpr + | TensorExpr EgisonExpr EgisonExpr EgisonExpr EgisonExpr + | TensorContractExpr EgisonExpr EgisonExpr | TensorMapExpr EgisonExpr EgisonExpr | TensorMap2Expr EgisonExpr EgisonExpr EgisonExpr | SomethingExpr | UndefinedExpr - deriving (Show, Eq) + deriving (Eq) +data Arg = + ScalarArg String + | TensorArg String + deriving (Eq) + +data Index a = + Subscript a + | Superscript a + | SupSubscript a + deriving (Eq) + data InnerExpr = ElementExpr EgisonExpr | SubCollectionExpr EgisonExpr @@ -255,7 +284,6 @@ WildCard | PatVar String | ValuePat EgisonExpr - | RegexPat EgisonExpr | PredPat EgisonExpr | IndexedPat EgisonPattern [EgisonExpr] | LetPat [BindingExpr] EgisonPattern @@ -268,8 +296,13 @@ | LoopPat String LoopRange EgisonPattern EgisonPattern | ContPat | PApplyPat EgisonExpr [EgisonPattern] - | DApplyPat EgisonPattern [EgisonPattern] | VarPat String + -- For symbolic computing + | DApplyPat EgisonPattern [EgisonPattern] + | DivPat EgisonPattern EgisonPattern + | PlusPat [EgisonPattern] + | MultPat [EgisonPattern] + | PowerPat EgisonPattern EgisonPattern deriving (Show, Eq) data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern @@ -303,7 +336,7 @@ | String Text | Bool Bool | ScalarData ScalarData - | TensorData TensorData + | TensorData (Tensor EgisonValue) | Float Double Double | InductiveData String [EgisonValue] | Tuple [EgisonValue] @@ -314,19 +347,22 @@ | StrHash (HashMap Text EgisonValue) | UserMatcher Env PMMode MatcherInfo | Func (Maybe String) Env [String] EgisonExpr + | PartialFunc Env Integer EgisonExpr | CFunc (Maybe String) Env String EgisonExpr | MemoizedFunc (Maybe String) ObjectRef (IORef (HashMap [Integer] ObjectRef)) Env [String] EgisonExpr + | Proc (Maybe String) Env [String] EgisonExpr | Macro [String] EgisonExpr | PatternFunc Env [String] EgisonPattern | PrimitiveFunc String PrimitiveFunc | IOFunc (EgisonM WHNFData) + | QuotedFunc EgisonValue | Port Handle | Something | Undefined | EOF -- --- Scalars +-- Scalar and Tensor Types -- data ScalarData = @@ -335,21 +371,86 @@ data PolyExpr = Plus [TermExpr] - deriving (Eq) data TermExpr = Term Integer [(SymbolExpr, Integer)] - deriving (Eq) data SymbolExpr = - Symbol String [Integer] + Symbol String String [Index ScalarData] -- ID, Name, Indices | Apply EgisonValue [ScalarData] + | Quote ScalarData deriving (Eq) +instance Eq PolyExpr where + (Plus []) == (Plus []) = True + (Plus (x:xs)) == (Plus ys) = + case findIndex ((==) x) ys of + Just i -> let (hs, _:ts) = splitAt i ys in + (Plus xs) == (Plus (hs ++ ts)) + Nothing -> False + _ == _ = False -symbolScalarData :: String -> [Integer] -> EgisonValue -symbolScalarData name js = (ScalarData (Div (Plus [(Term 1 [(Symbol name js, 1)])]) (Plus [(Term 1 [])]))) +instance Eq TermExpr where + (Term a []) == (Term b []) + | a /= b = False + | otherwise = True + (Term a (x:xs)) == (Term b ys) + | a /= b = False + | otherwise = case findIndex ((==) x) ys of + Just i -> let (hs, _:ts) = splitAt i ys in + (Term a xs) == (Term b (hs ++ ts)) + Nothing -> False + _ == _ = False + +data Tensor a = + Tensor [Integer] (V.Vector a) [Index EgisonValue] + | Scalar a + deriving (Show) + +class HasTensor a where + tensorElems :: a -> V.Vector a + tensorSize :: a -> [Integer] + tensorIndices :: a -> [Index EgisonValue] + fromTensor :: (Tensor a) -> EgisonM a + toTensor :: a -> EgisonM (Tensor a) + undef :: a + +instance HasTensor EgisonValue where + tensorElems (TensorData (Tensor _ xs _)) = xs + tensorSize (TensorData (Tensor ns _ _)) = ns + tensorIndices (TensorData (Tensor _ _ js)) = js + fromTensor (Tensor [] xs []) = + if V.length xs == 1 + then return $ V.head xs + else throwError $ InconsistentTensorIndex + fromTensor t@(Tensor _ _ _) = return $ TensorData t + fromTensor (Scalar x) = return x + toTensor (TensorData t) = return t + toTensor x = return $ Scalar x + undef = Undefined + +instance HasTensor WHNFData where + tensorElems (Intermediate (ITensor (Tensor _ xs _))) = xs + tensorSize (Intermediate (ITensor (Tensor ns _ _))) = ns + tensorIndices (Intermediate (ITensor (Tensor _ _ js))) = js + fromTensor (Tensor [] xs []) = + if V.length xs == 1 + then return $ V.head xs + else throwError $ InconsistentTensorIndex + fromTensor t@(Tensor _ _ _) = return $ Intermediate $ ITensor t + fromTensor (Scalar x) = return x + toTensor (Intermediate (ITensor t)) = return t + toTensor x = return $ Scalar x + undef = Value Undefined + +-- +-- Scalars +-- + +symbolScalarData :: String -> String -> EgisonValue +symbolScalarData id name = ScalarData (Div (Plus [(Term 1 [(Symbol id name [], 1)])]) (Plus [(Term 1 [])])) + mathExprToEgison :: ScalarData -> EgisonValue mathExprToEgison (Div p1 p2) = InductiveData "Div" [(polyExprToEgison p1), (polyExprToEgison p2)] @@ -360,8 +461,12 @@ termExprToEgison (Term a xs) = InductiveData "Term" [toEgison a, Collection (Sq.fromList (map symbolExprToEgison xs))] symbolExprToEgison :: (SymbolExpr, Integer) -> EgisonValue -symbolExprToEgison (Symbol x js, n) = Tuple [InductiveData "Symbol" [toEgison (T.pack x), toEgison js], toEgison n] +symbolExprToEgison (Symbol id x js, n) = Tuple [InductiveData "Symbol" [symbolScalarData id x, Collection (Sq.fromList (map (\j -> case j of + Superscript k -> InductiveData "Sup" [ScalarData k] + Subscript k -> InductiveData "Sub" [ScalarData k] + ) js))], toEgison n] symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n] +symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n] egisonToScalarData :: EgisonValue -> EgisonM ScalarData egisonToScalarData (InductiveData "Div" [p1, p2]) = Div <$> egisonToPolyExpr p1 <*> egisonToPolyExpr p2 @@ -375,6 +480,9 @@ egisonToScalarData s1@(InductiveData "Apply" _) = do s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)]) return $ Div (Plus [(Term 1 [s1'])]) (Plus [(Term 1 [])]) +egisonToScalarData s1@(InductiveData "Quote" _) = do + s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)]) + return $ Div (Plus [(Term 1 [s1'])]) (Plus [(Term 1 [])]) egisonToScalarData val = liftError $ throwError $ TypeMismatch "math expression" (Value val) egisonToPolyExpr :: EgisonValue -> EgisonM PolyExpr @@ -386,20 +494,63 @@ egisonToTermExpr val = liftError $ throwError $ TypeMismatch "math term expression" (Value val) egisonToSymbolExpr :: EgisonValue -> EgisonM (SymbolExpr, Integer) -egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, js], n]) = do - x' <- fromEgison x - js' <- fromEgison js +egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, (Collection seq)], n]) = do + let js = toList seq + js' <- mapM (\j -> case j of + InductiveData "Sup" [ScalarData k] -> return (Superscript k) + InductiveData "Sub" [ScalarData k] -> return (Subscript k) + _ -> liftError $ throwError $ TypeMismatch "math symbol expression" (Value j) + ) js n' <- fromEgison n - return (Symbol (T.unpack x') js', n') + case x of + (ScalarData (Div (Plus [(Term 1 [(Symbol id name [], 1)])]) (Plus [(Term 1 [])]))) -> + return (Symbol id name js', n') egisonToSymbolExpr (Tuple [InductiveData "Apply" [fn, (Collection mExprs)], n]) = do mExprs' <- mapM egisonToScalarData (toList mExprs) n' <- fromEgison n return (Apply fn mExprs', n') +egisonToSymbolExpr (Tuple [InductiveData "Quote" [mExpr], n]) = do + mExpr' <- egisonToScalarData mExpr + n' <- fromEgison n + return (Quote mExpr', n') egisonToSymbolExpr val = liftError $ throwError $ TypeMismatch "math symbol expression" (Value val) mathNormalize' :: ScalarData -> ScalarData -mathNormalize' mExpr = mathReduceSymbolFraction (mathReduceFraction (mathRemoveZero (mathFold (mathRemoveZeroSymbol mExpr)))) +mathNormalize' mExpr = mathDivide (mathRemoveZero (mathFold (mathRemoveZeroSymbol mExpr))) +mathDivide :: ScalarData -> ScalarData +mathDivide (Div (Plus ts1) (Plus [])) = (Div (Plus ts1) (Plus [])) +mathDivide (Div (Plus []) (Plus ts2)) = (Div (Plus []) (Plus ts2)) +mathDivide (Div (Plus ts1) (Plus [(Term a xs)])) = + case f (Term a xs) ts1 of + Nothing -> (Div (Plus ts1) (Plus [(Term a xs)])) + Just ts1' -> (Div (Plus ts1') (Plus [(Term 1 [])])) + where + f :: TermExpr -> [TermExpr] -> Maybe [TermExpr] + f _ [] = Just [] + f t1 (t:ts) = do t' <- f' t1 t + ts' <- f t1 ts + return (t':ts') + f' :: TermExpr -> TermExpr -> Maybe TermExpr + f' (Term a xs) (Term b ys) = + if b `mod` a == 0 + then do ys' <- g xs ys + return (Term (b `quot` a) ys') + else Nothing + g :: [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> Maybe [(SymbolExpr, Integer)] + g [] ys = Just ys + g ((x,n):xs) ys = do + ys' <- g' (x,n) ys + g xs ys' + g' :: (SymbolExpr, Integer) -> [(SymbolExpr, Integer)] -> Maybe [(SymbolExpr, Integer)] + g' (x, n) [] = Nothing + g' (x, n) ((y, m):ys) = do + if (x == y && n <= m) + then Just ((y, (m - n)):ys) + else do ys' <- g' (x,n) ys + return ((y,m):ys') +mathDivide (Div (Plus ts1) (Plus ts2)) = (Div (Plus ts1) (Plus ts2)) + mathRemoveZeroSymbol :: ScalarData -> ScalarData mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) = let p x = case x of @@ -417,48 +568,6 @@ [] -> Div (Plus []) (Plus [Term 1 []]) _ -> Div (Plus ts1') (Plus ts2') -mathReduceFraction :: ScalarData -> ScalarData -mathReduceFraction (Div (Plus []) (Plus ts2)) = Div (Plus []) (Plus ts2) -mathReduceFraction (Div (Plus ts1) (Plus [])) = Div (Plus ts1) (Plus []) -mathReduceFraction (Div (Plus ts1) (Plus ts2)) = - let as1 = map (\(Term a _) -> a) ts1 in - let as2 = map (\(Term a _) -> a) ts2 in - let flg = case as2 of - [a2] -> if a2 < 0 - then -1 - else 1 - _ -> 1 in - let d = (foldl gcd (head as1) ((tail as1) ++ as2)) * flg in - let us1 = map (\(Term a xs) -> Term (a `quot` d) xs) ts1 in - let us2 = map (\(Term a xs) -> Term (a `quot` d) xs) ts2 in - Div (Plus us1) (Plus us2) - -mathReduceSymbolFraction :: ScalarData -> ScalarData -mathReduceSymbolFraction (Div (Plus ts) (Plus ((Term a xs):[]))) = f xs [] ts - where - f :: [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> [TermExpr] -> ScalarData - f [] ret ts = Div (Plus ts) (Plus [Term a ret]) - f ((x, n):xs) ret ts = - let k = g x ts in - if n > k - then f xs (ret ++ [(x, (n - k))]) (h x k ts) - else f xs ret (h x n ts) - g :: SymbolExpr -> [TermExpr] -> Integer - g x ts = minimum (map (\(Term _ xs) -> g' x xs) ts) - g' :: SymbolExpr -> [(SymbolExpr, Integer)] -> Integer - g' x [] = 0 - g' x ((y, n):xs) = if x == y - then n - else g' x xs - h :: SymbolExpr -> Integer -> [TermExpr] -> [TermExpr] - h x k ts = map (\(Term a xs) -> Term a (filter (\(y, n) -> n /= 0) - (map (\(y, n) -> if x == y - then (y, (n - k)) - else (y, n)) - xs))) - ts -mathReduceSymbolFraction mExpr = mExpr - mathFold :: ScalarData -> ScalarData mathFold mExpr = (mathTermFold (mathSymbolFold (mathTermFold mExpr))) @@ -540,169 +649,366 @@ mathDenominator (Div _ n) = Div n (Plus [(Term 1 [])]) -- --- Tensors +-- ExtractScalar -- -data TensorData = - TData (Tensor ScalarData) (Maybe [ScalarData]) - deriving (Eq) +extractScalar :: EgisonValue -> EgisonM ScalarData +extractScalar (ScalarData mExpr) = return mExpr +extractScalar val = throwError $ TypeMismatch "math expression" (Value val) -data Tensor a = Tensor [Integer] [a] - deriving (Eq) +extractScalar' :: WHNFData -> EgisonM ScalarData +extractScalar' (Value (ScalarData x)) = return x +extractScalar' val = throwError $ TypeMismatch "integer or string" $ val -scalarToUnitTensor :: [Integer] -> ScalarData -> (Maybe [ScalarData]) -> TensorData -scalarToUnitTensor ns x js = makeTensor ns (map (\ms -> if all (\m -> m == (head ms)) (tail ms) - then x - else (Div (Plus []) (Plus [(Term 1 [])]))) (tensorIndices ns)) - js +-- +-- Tensors +-- -scalarToTensor :: [Integer] -> ScalarData -> (Maybe [ScalarData]) -> TensorData -scalarToTensor ns x js = makeTensor ns (map (\ms -> x) (tensorIndices ns)) js +initTensor :: [Integer] -> [a] -> [EgisonValue] -> [EgisonValue] -> (Tensor a) +initTensor ns xs sup sub = Tensor ns (V.fromList xs) ((map Superscript sup) ++ (map Subscript sub)) -makeTensor :: [Integer] -> [ScalarData] -> (Maybe [ScalarData]) -> TensorData -makeTensor ns xs js = TData (Tensor ns xs) js +tSize :: (Tensor a) -> [Integer] +tSize (Tensor ns _ _) = ns +tSize (Scalar _) = [] -tensorIndices :: [Integer] -> [[Integer]] -tensorIndices [] = [[]] -tensorIndices (n:ns) = concat (map (\i -> (map (\is -> i:is) (tensorIndices ns))) [1..n]) +tToList :: (Tensor a) -> [a] +tToList (Tensor _ xs _) = V.toList xs +tToList (Scalar x) = [x] -tMap :: (ScalarData -> EgisonM ScalarData) -> TensorData -> EgisonM TensorData -tMap f (TData (Tensor ns xs) js) = do - xs' <- mapM f xs - return $ TData (Tensor ns xs') js +tToVector :: (Tensor a) -> V.Vector a +tToVector (Tensor _ xs _) = xs +tToVector (Scalar x) = V.fromList [x] -tMap2 :: (ScalarData -> ScalarData -> EgisonM ScalarData) -> TensorData -> TensorData -> EgisonM TensorData -tMap2 f (TData t1@(Tensor ns1 xs1) (Just js1)) (TData t2@(Tensor ns2 xs2) (Just js2)) = do - ns2' <- transIndex js1 js2 ns2 - if ns1 == ns2' - then do ys <- mapM (\is -> do is' <- transIndex js1 js2 is - f (tref' is t1) (tref' is' t2)) - (tensorIndices ns1) - return $ makeTensor ns1 ys (Just js1) - else throwError $ InconsistentTensorSize -tMap2 f (TData t1@(Tensor ns1 xs1) Nothing) (TData t2@(Tensor ns2 xs2) Nothing) = do - if ns1 == ns2 - then do ys <- mapM (\is -> f (tref' is t1) (tref' is t2)) - (tensorIndices ns1) - return $ makeTensor ns1 ys Nothing - else throwError $ InconsistentTensorSize -tMap2 _ t1 t2 = do - throwError $ InconsistentTensorIndex -- TODO : new error type +tIndex :: (Tensor a) -> [Index EgisonValue] +tIndex (Tensor _ _ js) = js +tIndex (Scalar _) = [] -tSum :: [Tensor ScalarData] -> (Tensor ScalarData) -tSum (t:ts) = tSum' t ts - where - tSum' :: (Tensor ScalarData) -> [Tensor ScalarData] -> (Tensor ScalarData) - tSum' (Tensor ns xs) [] = Tensor ns xs - tSum' (Tensor ns xs) ((Tensor _ xs1):ts) = - tSum' (Tensor ns (map (\(x,y) -> mathNormalize' (mathPlus x y)) (zip xs xs1))) ts +tIntRef' :: HasTensor a => Integer -> (Tensor a) -> EgisonM a +tIntRef' i (Tensor [_] xs _) = fromTensor $ Scalar $ xs V.! (fromIntegral (i - 1)) +tIntRef' i (Tensor (n:ns) xs js) = + if (0 < i) && (i <= n) + then let w = fromIntegral (product ns) in + let ys = V.take w (V.drop (w * (fromIntegral (i - 1))) xs) in + fromTensor $ Tensor ns ys (cdr js) + else throwError $ TensorIndexOutOfBounds i n +tIntRef' i _ = throwError $ strMsg "More indices than the order of the tensor" + +tIntRef :: HasTensor a => [Integer] -> (Tensor a) -> EgisonM (Tensor a) +tIntRef [] (Tensor [] xs _) + | V.length xs == 1 = return $ Scalar (xs V.! 0) + | otherwise = throwError $ EgisonBug "sevaral elements in scalar tensor" +tIntRef [] t = return t +tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms -transIndex :: [ScalarData] -> [ScalarData] -> [Integer] -> EgisonM [Integer] -transIndex [] [] [] = return [] +tref :: HasTensor a => [Index EgisonValue] -> (Tensor a) -> EgisonM a +tref [] (Tensor [] xs _) + | V.length xs == 1 = fromTensor $ Scalar (xs V.! 0) + | otherwise = throwError $ EgisonBug "sevaral elements in scalar tensor" +tref [] t = fromTensor t +tref ((Subscript (ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])))):ms) t = tIntRef' m t >>= toTensor >>= tref ms +tref ((Superscript (ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])))):ms) t = tIntRef' m t >>= toTensor >>= tref ms +tref ((SupSubscript (ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])))):ms) t = tIntRef' m t >>= toTensor >>= tref ms +tref ((Subscript (Tuple [ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])), ScalarData (Div (Plus [(Term n [])]) (Plus [(Term 1 [])]))])):ms) t = do + ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n] + symId <- fresh + tConcat (Subscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor +tref ((Superscript (Tuple [ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])), ScalarData (Div (Plus [(Term n [])]) (Plus [(Term 1 [])]))])):ms) t = do + ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n] + symId <- fresh + tConcat (Superscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor +tref ((SupSubscript (Tuple [ScalarData (Div (Plus [(Term m [])]) (Plus [(Term 1 [])])), ScalarData (Div (Plus [(Term n [])]) (Plus [(Term 1 [])]))])):ms) t = do + ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n] + symId <- fresh + tConcat (SupSubscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor +tref (s:ms) (Tensor (n:ns) xs js) = do + let yss = split (product ns) xs + ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss + mapM toTensor ts >>= tConcat s >>= fromTensor +tref _ t = throwError $ strMsg "More indices than the order of the tensor" + +enumTensorIndices :: [Integer] -> [[Integer]] +enumTensorIndices [] = [[]] +enumTensorIndices (n:ns) = concat (map (\i -> (map (\is -> i:is) (enumTensorIndices ns))) [1..n]) + +transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> [Integer] -> EgisonM [Integer] +transIndex [] [] is = return is transIndex (j1:js1) js2 is = do let (hjs2, tjs2) = break (\j2 -> j1 == j2) js2 if tjs2 == [] - then throwError $ InconsistentTensorIndex + then do throwError $ InconsistentTensorIndex else do let n = (length hjs2) + 1 rs <- transIndex js1 (hjs2 ++ (tail tjs2)) ((take (n - 1) is) ++ (drop n is)) - return ((is !! (n - 1)):rs) + return ((nth (fromIntegral n) is):rs) transIndex _ _ _ = throwError $ InconsistentTensorSize -tContract :: TensorData -> EgisonM EgisonValue -tContract (TData t@(Tensor ns xs) (Just js)) = do - case (findPairs js) of - [] -> return $ TensorData (TData (Tensor ns xs) (Just js)) - ((hs,ms,ts):_) -> do - let hn = (length hs) + 1 - let mn = (length (hs ++ ms)) + 2 - if (ns !! (hn - 1)) == (ns !! (mn - 1)) - then do - let n = ns !! (hn - 1) - let ret = TData (tSum (map (\i -> (tref (hs ++ [(Div (Plus [(Term i [])]) (Plus [(Term 1 [])]))] ++ ms - ++ [(Div (Plus [(Term i [])]) (Plus [(Term 1 [])]))] ++ ts) t)) - [1..n])) - (Just (hs ++ ms ++ ts)) - case ret of - (TData (Tensor [] [x]) (Just [])) -> return $ ScalarData x - _ -> return $ TensorData ret - else throwError $ InconsistentTensorIndex +tTranspose :: HasTensor a => [Index EgisonValue] -> (Tensor a) -> EgisonM (Tensor a) +tTranspose is t@(Tensor ns xs js) = do + ns' <- transIndex js is ns + xs' <- mapM (transIndex js is) (enumTensorIndices ns') >>= mapM (flip tIntRef t) >>= mapM fromTensor >>= return . V.fromList + return $ Tensor ns' xs' is + +tMap :: HasTensor a => (a -> EgisonM a) -> (Tensor a) -> EgisonM (Tensor a) +tMap f (Tensor ns xs js) = do + xs' <- V.mapM f xs + t <- toTensor (V.head xs') + case t of + (Tensor ns1 _ js1) -> + tContract' $ Tensor (ns ++ ns1) (V.concat (V.toList (V.map tensorElems xs'))) (js ++ js1) + _ -> return $ Tensor ns xs' js +tMap f (Scalar x) = f x >>= return . Scalar + +tMapN :: HasTensor a => ([a] -> EgisonM a) -> [Tensor a] -> EgisonM (Tensor a) +tMapN f ts@((Tensor ns xs js):_) = do + xs' <- mapM (\is -> mapM (tIntRef is) ts >>= mapM fromTensor >>= f) (enumTensorIndices ns) + return $ Tensor ns (V.fromList xs') js +tMapN f xs = mapM fromTensor xs >>= f >>= return . Scalar + +tMap2 :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a) +tMap2 f t1@(Tensor ns1 xs1 js1) t2@(Tensor ns2 xs2 js2) = do + let (cjs, tjs1, tjs2) = h js1 js2 + t1' <- tTranspose (cjs ++ tjs1) t1 + t2' <- tTranspose (cjs ++ tjs2) t2 + let cns = take (length cjs) (tSize t1') + rts1 <- mapM (flip tIntRef t1') (enumTensorIndices cns) + rts2 <- mapM (flip tIntRef t2') (enumTensorIndices cns) + rts' <- mapM (\(t1, t2) -> tProduct f t1 t2) (zip rts1 rts2) + let ret = Tensor (cns ++ (tSize (head rts'))) (V.concat (map tToVector rts')) (cjs ++ tIndex (head rts')) + tTranspose (uniq (tDiagIndex (js1 ++ js2))) ret where - findPairs :: [ScalarData] -> [([ScalarData], [ScalarData], [ScalarData])] - findPairs xs = findPairs' [] xs - findPairs' :: [ScalarData] -> [ScalarData] -> [([ScalarData], [ScalarData], [ScalarData])] - findPairs' _ [] = [] - findPairs' hs (x:xs) = (findPairs'' hs x xs) ++ (findPairs' (hs ++ [x]) xs) - findPairs'' :: [ScalarData] -> ScalarData -> [ScalarData] -> [([ScalarData], [ScalarData], [ScalarData])] - findPairs'' hs x xs = - let (hxs, txs) = break (\e -> e == x) xs in - if txs == [] - then [] - else [(hs, hxs, (tail txs))] -tContract (TData _ Nothing) = throwError $ InconsistentTensorIndex -- TODO : new error type + h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue]) + h js1 js2 = let cjs = filter (\j -> elem j js2) js1 in + (cjs, js1 \\ cjs, js2 \\ cjs) + uniq :: [Index EgisonValue] -> [Index EgisonValue] + uniq [] = [] + uniq (x:xs) = x:(uniq (delete x xs)) +tMap2 f t@(Tensor _ _ _) (Scalar x) = tMap (flip f x) t +tMap2 f (Scalar x) t@(Tensor _ _ _) = tMap (f x) t +tMap2 f (Scalar x1) (Scalar x2) = f x1 x2 >>= return . Scalar -tCheckIndex :: [ScalarData] -> [Integer] -> EgisonM () -tCheckIndex [] [] = return () -tCheckIndex ((Div (Plus [(Term m [])]) (Plus [(Term 1 [])])):ms) (n:ns) = - if (0 < m) && (m <= n) - then tCheckIndex ms ns - else throwError $ TensorIndexOutOfBounds m n -tCheckIndex (Div (Plus [(Term 1 [(Symbol _ _, 1)])]) (Plus [(Term 1 [])]):ms) (n:ns) = tCheckIndex ms ns -tCheckIndex (m:_) _ = throwError $ TypeMismatch "symbol or natural number" (Value (ScalarData m)) +tDiag :: HasTensor a => Tensor a -> EgisonM (Tensor a) +tDiag t@(Tensor _ _ js) = do + case filter (\j -> any (p j) js) js of + [] -> return t + xs -> do + let ys = js \\ (xs ++ (map rev xs)) + t2 <- tTranspose (xs ++ (map rev xs) ++ ys) t + let (ns1, tmp) = splitAt (length xs) (tSize t2) + let (_, ns2) = splitAt (length xs) tmp + ts <- mapM (\is -> tIntRef (is ++ is) t2) (enumTensorIndices ns1) + return $ Tensor (ns1 ++ ns2) (V.concat (map tToVector ts)) ((map g xs) ++ ys) + where + p :: Index EgisonValue -> Index EgisonValue -> Bool + p (Superscript i) (Subscript j) = i == j + p (Subscript i) _ = False + p _ _ = False + rev :: Index EgisonValue -> Index EgisonValue + rev (Superscript i) = (Subscript i) + rev (Subscript i) = (Superscript i) + g :: Index EgisonValue -> Index EgisonValue + g (Superscript i) = (SupSubscript i) + g (Subscript i) = (SupSubscript i) +tDiag t = return t -tref' :: [Integer] -> (Tensor a) -> a -tref' ms (Tensor ns xs) = tref'' ms ns xs +tDiagIndex :: [Index EgisonValue] -> [Index EgisonValue] +tDiagIndex js = + let xs = filter (\j -> any (p j) js) js in + let ys = js \\ (xs ++ (map rev xs)) in + (map g xs) ++ ys where - tref'' :: [Integer] -> [Integer] -> [a] -> a - tref'' [m] [n] xs = xs !! (fromIntegral (m - 1)) - tref'' (m:ms) (n:ns) xs = - let w = fromIntegral (product ns) in - let ys = take w (drop (w * (fromIntegral (m - 1))) xs) in - tref'' ms ns ys + p :: Index EgisonValue -> Index EgisonValue -> Bool + p (Superscript i) (Subscript j) = i == j + p (Subscript _) _ = False + p _ _ = False + rev :: Index EgisonValue -> Index EgisonValue + rev (Superscript i) = (Subscript i) + rev (Subscript i) = (Superscript i) + g :: Index EgisonValue -> Index EgisonValue + g (Superscript i) = (SupSubscript i) + g (Subscript i) = (SupSubscript i) -tref :: [ScalarData] -> (Tensor a) -> (Tensor a) -tref ms (Tensor ns xs) = let rns = map snd (filter (\(m,_) -> (isSymbol (ScalarData m))) (zip ms ns)) in - let rxs = tsub' ms ns xs in - Tensor rns rxs +tSum :: HasTensor a => (a -> a -> EgisonM a) -> (Tensor a) -> (Tensor a) -> EgisonM (Tensor a) +tSum f t1@(Tensor ns1 xs1 js1) t2@(Tensor _ _ _) = do + t2' <- tTranspose js1 t2 + case t2' of + (Tensor ns2 xs2 _) + | ns2 == ns1 -> do ys <- mapM (\(x1,x2) -> f x1 x2) (V.zip xs1 xs2) + return (Tensor ns1 ys js1) + | otherwise -> throwError $ InconsistentTensorSize + +tProduct :: HasTensor a => (a -> a -> EgisonM a) -> (Tensor a) -> (Tensor a) -> EgisonM (Tensor a) +tProduct f t1@(Tensor ns1 xs1 js1) t2@(Tensor ns2 xs2 js2) = do + let (cjs1, cjs2, tjs1, tjs2) = h js1 js2 + case cjs1 of + [] -> do + xs' <- mapM (\is -> do let is1 = take (length ns1) is + let is2 = take (length ns2) (drop (length ns1) is) + x1 <- tIntRef is1 t1 >>= fromTensor + x2 <- tIntRef is2 t2 >>= fromTensor + f x1 x2) (enumTensorIndices (ns1 ++ ns2)) >>= return . V.fromList + tContract' (Tensor (ns1 ++ ns2) xs' (js1 ++ js2)) + _ -> do + t1' <- tTranspose (cjs1 ++ tjs1) t1 + t2' <- tTranspose (cjs2 ++ tjs2) t2 + let (cns1, tns1) = splitAt (length cjs1) (tSize t1') + let (cns2, tns2) = splitAt (length cjs2) (tSize t2') + rts' <- mapM (\is -> do rt1 <- tIntRef is t1' + rt2 <- tIntRef is t2' + tProduct f rt1 rt2) (enumTensorIndices cns1) + let ret = Tensor (cns1 ++ (tSize (head rts'))) (V.concat (map tToVector rts')) ((map g cjs1) ++ tIndex (head rts')) + tTranspose ((map g cjs1) ++ tjs1 ++ tjs2) ret where - tsub' :: [ScalarData] -> [Integer] -> [a] -> [a] - tsub' [] [] rs = rs - tsub' (m:ms) (n:ns) xs = - if isSymbol (ScalarData m) - then let w = fromIntegral (product ns) in - let yss = split w xs in - concat (map (\ys -> tsub' ms ns ys) yss) - else let i = extractInteger m in - let w = fromIntegral (product ns) in - let ys = take w (drop (w * (fromIntegral (i - 1))) xs) in - tsub' ms ns ys - split :: Int -> [a] -> [[a]] - split _ [] = [[]] - split w xs = let (hs, ts) = splitAt w xs in + h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue], [Index EgisonValue]) + h js1 js2 = let cjs = filter (\j -> any (p j) js2) js1 in + (cjs, map rev cjs, js1 \\ cjs, js2 \\ (map rev cjs)) + p :: Index EgisonValue -> Index EgisonValue -> Bool + p (Superscript i) (Subscript j) = i == j + p (Subscript i) (Superscript j) = i == j + p _ _ = False + rev :: Index EgisonValue -> Index EgisonValue + rev (Superscript i) = (Subscript i) + rev (Subscript i) = (Superscript i) + g :: Index EgisonValue -> Index EgisonValue + g (Superscript i) = (SupSubscript i) + g (Subscript i) = (SupSubscript i) +tProduct f (Scalar x) (Tensor ns xs js) = do + xs' <- mapM (f x) xs + return $ Tensor ns xs' js +tProduct f (Tensor ns xs js) (Scalar x) = do + xs' <- mapM (flip f x) xs + return $ Tensor ns xs' js +tProduct f (Scalar x1) (Scalar x2) = f x1 x2 >>= return . Scalar + +tContract :: HasTensor a => (Tensor a) -> EgisonM [Tensor a] +tContract t = do + t' <- tDiag t + case t' of + (Tensor (n:ns) xs ((SupSubscript i):js)) -> do + ts <- mapM (\k -> tIntRef' k t') [1..n] + tss <- mapM toTensor ts >>= mapM tContract + return $ concat tss + _ -> return [t'] + +tContract' :: HasTensor a => (Tensor a) -> EgisonM (Tensor a) +tContract' t@(Tensor ns xs js) = do + case findPairs p js of + [] -> return t + ((m,n):_) -> do + let ns' = (ns !! m):removePairs (m,n) ns + let js' = (js !! m):removePairs (m,n) js + let (hjs, mjs, tjs) = removePairs' (m,n) js + xs' <- mapM (\i -> (tref (hjs ++ [Subscript (ScalarData (Div (Plus [(Term i [])]) (Plus [(Term 1 [])])))] ++ mjs + ++ [Subscript (ScalarData (Div (Plus [(Term i [])]) (Plus [(Term 1 [])])))] ++ tjs) t)) + [1..(ns !! m)] + mapM toTensor xs' >>= tConcat (js !! m) >>= tTranspose (hjs ++ [js !! m] ++ mjs ++ tjs) >>= tContract' + where + p :: Index EgisonValue -> Index EgisonValue -> Bool + p (Superscript i) (Superscript j) = i == j + p (Subscript i) (Subscript j) = i == j + p _ _ = False +tContract' val = return val + +-- utility functions for tensors + +nth :: Integer -> [a] -> a +nth i xs = xs !! (fromIntegral (i - 1)) + +cdr :: [a] -> [a] +cdr [] = [] +cdr (_:ts) = ts + +split :: Integer -> V.Vector a -> [V.Vector a] +split w xs + | V.null xs = [] + | otherwise = let (hs, ts) = V.splitAt (fromIntegral w) xs in hs:(split w ts) - extractInteger :: ScalarData -> Integer - extractInteger (Div (Plus []) (Plus [(Term 1 [])])) = 0 - extractInteger (Div (Plus [(Term i [])]) (Plus [(Term 1 [])])) = i -tSize :: TensorData -> [Integer] -tSize (TData (Tensor ns _) _) = ns +tConcat :: HasTensor a => Index EgisonValue -> [Tensor a] -> EgisonM (Tensor a) +tConcat s ts@((Tensor ns _ js):_) = return $ Tensor ((fromIntegral (length ts)):ns) (V.concat (map tToVector ts)) (s:js) +tConcat s ts = do + ts' <- mapM getScalar ts + return $ Tensor [fromIntegral (length ts)] (V.fromList ts') [s] -tToList :: (Tensor a) -> [a] -tToList (Tensor _ xs) = xs +tConcat' :: HasTensor a => [Tensor a] -> EgisonM (Tensor a) +tConcat' ts@((Tensor ns _ _):_) = return $ Tensor ((fromIntegral (length ts)):ns) (V.concat (map tToVector ts)) [] +tConcat' ts = do + ts' <- mapM getScalar ts + return $ Tensor [fromIntegral (length ts)] (V.fromList ts') [] -tIndex :: TensorData -> Maybe [ScalarData] -tIndex (TData (Tensor _ _) js) = js +tClearIndex :: HasTensor a => Tensor a -> Tensor a +tClearIndex (Tensor ns xs js) = Tensor ns xs (tClearIndex' js) +tClearIndex s@(Scalar _) = s +tClearIndex' :: [Index EgisonValue] -> [Index EgisonValue] +tClearIndex' js = reverse (g (reverse js)) + where + g :: [Index EgisonValue] -> [Index EgisonValue] + g [] = [] + g ((Superscript (ScalarData (Div (Plus [(Term 1 [(Symbol _ (':':':':':':_) [], 1)])]) (Plus [(Term 1 [])])))):js) = g js + g ((Subscript (ScalarData (Div (Plus [(Term 1 [(Symbol _ (':':':':':':_) [], 1)])]) (Plus [(Term 1 [])])))):js) = g js + g ((SupSubscript (ScalarData (Div (Plus [(Term 1 [(Symbol _ (':':':':':':_) [], 1)])]) (Plus [(Term 1 [])])))):js) = g js + g js = js + +getScalar :: (Tensor a) -> EgisonM a +getScalar (Scalar x) = return x +getScalar _ = throwError $ strMsg "Inconsitent Tensor order" + +findPairs :: (a -> a -> Bool) -> [a] -> [(Int, Int)] +findPairs p xs = reverse $ findPairs' 0 p xs + +findPairs' :: Int -> (a -> a -> Bool) -> [a] -> [(Int, Int)] +findPairs' _ _ [] = [] +findPairs' m p (x:xs) = case findIndex (p x) xs of + Just i -> (m, m + i + 1):(findPairs' (m + 1) p xs) + Nothing -> findPairs' (m + 1) p xs + +removePairs :: (Int, Int) -> [a] -> [a] +removePairs (m, n) xs = + let (hs, ms, ts) = removePairs' (m, n) xs in + hs ++ ms ++ ts + +removePairs' :: (Int, Int) -> [a] -> ([a],[a],[a]) +removePairs' (m, n) xs = -- (0,1) [i i] + let (hms, tts) = splitAt n xs in -- [i] [i] + let ts = tail tts in -- [] + let (hs, tms) = splitAt m hms in -- [] [i] + let ms = tail tms in -- [] + (hs, ms, ts) -- [] [] [] +-- +-- +-- + type Matcher = EgisonValue type PrimitiveFunc = WHNFData -> EgisonM WHNFData +instance Show EgisonExpr where + show (CharExpr c) = "c#" ++ [c] + show (StringExpr str) = "\"" ++ T.unpack str ++ "\"" + show (BoolExpr True) = "#t" + show (BoolExpr False) = "#f" + show (IntegerExpr n) = show n + show (FloatExpr x y) = showComplexFloat x y + show (VarExpr name) = name + show (PartialVarExpr n) = "%" ++ show n + + show (ApplyExpr fn (TupleExpr [])) = "(" ++ show fn ++ ")" + show (ApplyExpr fn (TupleExpr args)) = "(" ++ show fn ++ " " ++ unwords (map show args) ++ ")" + show (ApplyExpr fn arg) = "(" ++ show fn ++ " " ++ show arg ++ ")" + + instance Show EgisonValue where - show (Char c) = "'" ++ [c] ++ "'" + show (Char c) = "c#" ++ [c] show (String str) = "\"" ++ T.unpack str ++ "\"" show (Bool True) = "#t" show (Bool False) = "#f" show (ScalarData mExpr) = show mExpr - show (TensorData tExpr) = show tExpr +-- show (TensorData (Scalar x)) = "invalid scalar:" ++ show x + show (TensorData (Tensor [_] xs js)) = "[| " ++ unwords (map show (V.toList xs)) ++ " |]" ++ concat (map show js) + show (TensorData (Tensor [i, j] xs js)) = "[| " ++ f (fromIntegral j) (V.toList xs) ++ "|]" ++ concat (map show js) + where + f j [] = "" + f j xs = "[| " ++ unwords (map show (take j xs)) ++ " |] " ++ f j (drop j xs) + show (TensorData (Tensor ns xs js)) = "(tensor {" ++ unwords (map show ns) ++ "} {" ++ unwords (map show (V.toList xs)) ++ "} )" ++ concat (map show js) show (Float x y) = showComplexFloat x y show (InductiveData name []) = "<" ++ name ++ ">" show (InductiveData name vals) = "<" ++ name ++ " " ++ unwords (map show vals) ++ ">" @@ -710,28 +1016,36 @@ show (Collection vals) = if Sq.null vals then "{}" else "{" ++ unwords (map show (toList vals)) ++ "}" - show (Array vals) = "[|" ++ unwords (map show $ Array.elems vals) ++ "|]" + show (Array vals) = "(|" ++ unwords (map show $ Array.elems vals) ++ "|)" show (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show (CharHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[\"" ++ T.unpack key ++ "\" " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show (UserMatcher _ BFSMode _) = "#" show (UserMatcher _ DFSMode _) = "#" - show (Func Nothing _ names _) = "(lambda [" ++ unwords names ++ "] ...)" + show (Func Nothing _ args _) = "(lambda [" ++ unwords (map show args) ++ "] ...)" show (Func (Just name) _ _ _) = name + show (PartialFunc _ n expr) = show n ++ "#" ++ show expr show (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)" show (CFunc (Just name) _ _ _) = name show (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ unwords names ++ "] ...)" show (MemoizedFunc (Just name) _ _ _ names _) = name + show (Proc Nothing _ names _) = "(procedure [" ++ unwords names ++ "] ...)" + show (Proc (Just name) _ _ _) = name show (Macro names _) = "(macro [" ++ unwords names ++ "] ...)" show (PatternFunc _ _ _) = "#" show (PrimitiveFunc name _) = "#" show (IOFunc _) = "#" + show (QuotedFunc _) = "#" show (Port _) = "#" show Something = "something" show Undefined = "undefined" show World = "#" show EOF = "#" +instance Show Arg where + show (ScalarArg name) = "$" ++ name + show (TensorArg name) = "%" ++ name + instance Show ScalarData where show (Div p1 (Plus [(Term 1 [])])) = show p1 show (Div p1 p2) = "(/ " ++ show p1 ++ " " ++ show p2 ++ ")" @@ -752,9 +1066,11 @@ showPoweredSymbol (x, n) = show x ++ "^" ++ show n instance Show SymbolExpr where - show (Symbol s []) = s - show (Symbol s js) = s ++ unwords' (map show js) + show (Symbol _ (':':':':':':_) []) = "#" + show (Symbol _ s []) = s + show (Symbol _ s js) = s ++ concat (map show js) show (Apply fn mExprs) = "(" ++ show fn ++ " " ++ unwords (map show mExprs) ++ ")" + show (Quote mExprs) = "'" ++ show mExprs showComplex :: (Num a, Eq a, Ord a, Show a) => a -> a -> String showComplex x 0 = show x @@ -764,18 +1080,9 @@ showComplexFloat :: Double -> Double -> String showComplexFloat x 0.0 = showFFloat Nothing x "" showComplexFloat 0.0 y = showFFloat Nothing y "i" -showComplexFloat x y = showFFloat Nothing x "" ++ if y > 0 then "+" else "" ++ showFFloat Nothing y "i" - -instance Show TensorData where - show (TData xs Nothing) = show xs - show (TData xs (Just indices)) = show xs ++ unwords' (map show indices) - -unwords' [] = "" -unwords' (x:xs) = "_" ++ x ++ unwords' xs - -instance Show (Tensor ScalarData) where - show (Tensor ns xs) = "(| {" ++ unwords (map show ns) ++ "} {" ++ unwords (map show xs) ++ "} |)" - +showComplexFloat x y = showFFloat Nothing x "" ++ if y > 0 + then "+" ++ showFFloat Nothing y "i" + else showFFloat Nothing y "i" showTSV :: EgisonValue -> String showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map showTSV vals) @@ -787,7 +1094,7 @@ (String str) == (String str') = str == str' (Bool b) == (Bool b') = b == b' (ScalarData x) == (ScalarData y) = (x == y) - (TensorData x) == (TensorData y) = (x == y) + (TensorData (Tensor js xs _)) == (TensorData (Tensor js' xs' _)) = (js == js') && (xs == xs') (Float x y) == (Float x' y') = (x == x') && (y == y') (InductiveData name vals) == (InductiveData name' vals') = (name == name') && (vals == vals') (Tuple vals) == (Tuple vals') = vals == vals' @@ -928,6 +1235,7 @@ | IIntHash (HashMap Integer ObjectRef) | ICharHash (HashMap Char ObjectRef) | IStrHash (HashMap Text ObjectRef) + | ITensor (Tensor WHNFData) data Inner = IElement ObjectRef @@ -938,10 +1246,11 @@ show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>" show (Intermediate (ITuple _)) = "[...]" show (Intermediate (ICollection _)) = "{...}" - show (Intermediate (IArray _)) = "[|...|]" + show (Intermediate (IArray _)) = "(|...|)" show (Intermediate (IIntHash _)) = "{|...|}" show (Intermediate (ICharHash _)) = "{|...|}" show (Intermediate (IStrHash _)) = "{|...|}" + show (Intermediate (ITensor _)) = "[|...|]" instance Show Object where show (Thunk _) = "#" @@ -1009,19 +1318,43 @@ -- Environment -- -data Env = Env [HashMap Var ObjectRef] +data Env = Env [HashMap String ObjectRef] deriving (Show) -type Var = String -type Binding = (Var, ObjectRef) +data Var = Var String [Index ()] + deriving (Eq) +type Binding = (String, ObjectRef) +instance Show Var where + show (Var x is) = x ++ concat (map show is) + +instance Show (Index ()) where + show (Superscript ()) = "~" + show (Subscript ()) = "_" + show (SupSubscript ()) = "~_" + +instance Show (Index EgisonExpr) where + show (Superscript i) = "~" ++ show i + show (Subscript i) = "_" ++ show i + show (SupSubscript i) = "~_" ++ show i + +instance Show (Index ScalarData) where + show (Superscript i) = "~" ++ show i + show (Subscript i) = "_" ++ show i + show (SupSubscript i) = "~_" ++ show i + +instance Show (Index EgisonValue) where + show (Superscript i) = "~" ++ show i + show (Subscript i) = "_" ++ show i + show (SupSubscript i) = "~_" ++ show i + nullEnv :: Env nullEnv = Env [] extendEnv :: Env -> [Binding] -> Env extendEnv (Env env) = Env . (: env) . HashMap.fromList -refVar :: Env -> Var -> Maybe ObjectRef +refVar :: Env -> String -> Maybe ObjectRef refVar (Env env) var = msum $ map (HashMap.lookup var) env -- @@ -1042,11 +1375,11 @@ deriving (Show) data MatchingTree = - MAtom EgisonPattern ObjectRef Matcher + MAtom EgisonPattern WHNFData Matcher | MNode [PatternBinding] MatchingState deriving (Show) -type PatternBinding = (Var, EgisonPattern) +type PatternBinding = (String, EgisonPattern) data LoopPatContext = LoopPatContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern deriving (Show) @@ -1056,7 +1389,7 @@ -- data EgisonError = - UnboundVariable Var + UnboundVariable String | TypeMismatch String WHNFData | ArgumentsNumWithNames [String] Int Int | ArgumentsNumPrimitive Int Int @@ -1075,7 +1408,7 @@ instance Show EgisonError where show (Parser err) = "Parse error at: " ++ err - show (UnboundVariable var) = "Unbound variable: " ++ var + show (UnboundVariable var) = "Unbound variable: " ++ show var show (TypeMismatch expected found) = "Expected " ++ expected ++ ", but found: " ++ show found show (ArgumentsNumWithNames names expected got) = "Wrong number of arguments: " ++ show names ++ ": expected " ++ @@ -1250,16 +1583,16 @@ isRational' (Value val) = return $ Value $ Bool $ isRational val isSymbol :: EgisonValue -> Bool -isSymbol (ScalarData (Div (Plus [(Term 1 [(Symbol _ _, 1)])]) (Plus [(Term 1 [])]))) = True +isSymbol (ScalarData (Div (Plus [(Term 1 [(Symbol _ _ _, 1)])]) (Plus [(Term 1 [])]))) = True isSymbol _ = False -isNumber :: EgisonValue -> Bool -isNumber (ScalarData _) = True -isNumber _ = False +isScalar :: EgisonValue -> Bool +isScalar (ScalarData _) = True +isScalar _ = False -isNumber' :: PrimitiveFunc -isNumber' (Value val) = return $ Value $ Bool $ isNumber val -isNumber' _ = return $ Value $ Bool False +isScalar' :: PrimitiveFunc +isScalar' (Value val) = return $ Value $ Bool $ isScalar val +isScalar' _ = return $ Value $ Bool False isTensor :: EgisonValue -> Bool isTensor (TensorData _) = True @@ -1270,7 +1603,7 @@ isTensor' _ = return $ Value $ Bool False isTensorWithIndex :: EgisonValue -> Bool -isTensorWithIndex (TensorData (TData (Tensor _ _) (Just ms))) = True +isTensorWithIndex (TensorData (Tensor _ _ (_:_))) = True isTensorWithIndex _ = False isTensorWithIndex' :: PrimitiveFunc diff --git a/lib/core/assoc.egi b/lib/core/assoc.egi --- a/lib/core/assoc.egi +++ b/lib/core/assoc.egi @@ -35,14 +35,14 @@ {[ {[x rs]}] [ {[x {[x (- n 1)] @rs}]}] [_ {}]})]}] - [ [a (assoc-list a)] + [ [a (assoc-list a)] {[$tgt (match tgt (list [something integer]) {[ {[x rs]}] [ {[x {[x (- n k)] @rs}]}] [_ {}]})]}] - [ [integer a (assoc-list a)] + [ [a integer (assoc-list a)] {[$tgt (match tgt (list [something integer]) - {[ {[k x rs]}] + {[ {[x k rs]}] [_ {}]})]}] [,$val [] {[$tgt (if (eq? val tgt) {[]} {})]}] @@ -72,26 +72,26 @@ (if (eq? n 1) [x {@hs @ts}] [x {@hs [x (- n 1)] @ts}])])]}] - [ [(assoc-multiset a)] + [ [(assoc-multiset a)] {[$tgt (match-all tgt (list [a integer]) [> (if (eq? (- k n) 0) {@hs @ts} {@hs [x (- k n)] @ts})])]}] - [ [a (assoc-multiset a)] + [ [a (assoc-multiset a)] {[$tgt (match-all tgt (list [a integer]) [> (if (eq? (- k n) 0) [x {@hs @ts}] [x {@hs [x (- k n)] @ts}])])]}] - [ [integer (assoc-multiset a)] + [ [integer (assoc-multiset a)] {[$tgt (match-all tgt (list [a integer]) [> [n {@hs @ts}]])]}] - [ [integer a (assoc-multiset a)] + [ [a integer (assoc-multiset a)] {[$tgt (match-all tgt (list [a integer]) [> - [n x {@hs @ts}]])]}] + [x n {@hs @ts}]])]}] [$ [something] {[$tgt {tgt}]}] }))) @@ -99,9 +99,9 @@ (define $AC.intersect (lambda [$xs $ys] (match-all [xs ys] [(assoc-multiset something) (assoc-multiset something)] - [[ ] [x (min m n)]]))) + [[ ] [x (min m n)]]))) (define $AC.intersect/m (lambda [$a $xs $ys] (match-all [xs ys] [(assoc-multiset a) (assoc-multiset a)] - [[ ] [x (min m n)]]))) + [[ ] [x (min m n)]]))) diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -28,15 +28,15 @@ (define $snd 2#%2) -(define $compose +(define $b.compose (lambda [$f $g] (lambda $x (apply g (apply f x))))) -(define $compose3 - (lambda [$f $g $h] +(define $compose + (cambda $fs (lambda $x - (apply h (apply g (apply f x)))))) + (foldl 2#(%2 %1) x fs)))) (define $ref (lambda [$xa $i] @@ -51,13 +51,16 @@ ;; ;; Boolean ;; -(define $and +(define $and (cambda $bs (foldl b.and #t bs))) +(define $or (cambda $bs (foldl b.or #f bs))) + +(define $b.and (lambda [$b1 $b2] (if b1 b2 #f))) -(define $or +(define $b.or (lambda [$b1 $b2] (if b1 #t diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -21,11 +21,11 @@ [_ {}]}] [ [(list a) (list a)] {[$tgt (match-all tgt (list a) - [(loop $i [1 $n] $rs) [(foldr (lambda [$i $r] {xa_i @r}) {} (between 1 n)) + [(loop $i [1 $n] $rs) [(foldr (lambda [%i %r] {xa_i @r}) {} (between 1 n)) rs]])]}] [ [(list a) (list a)] {[$tgt (match-all tgt (list a) - [(loop $i [1 $n] $rs) [(foldr (lambda [$i $r] {@r xa_i}) {} (between 1 n)) + [(loop $i [1 $n] $rs) [(foldr (lambda [%i %r] {@r xa_i}) {} (between 1 n)) rs]])]}] [,$val [] {[$tgt (if (eq? val tgt) {[]} {})]}] @@ -204,7 +204,7 @@ (define $filter (lambda [$pred $xs] - (foldr (lambda [$y $ys] (if (pred y) {y @ys} ys)) + (foldr (lambda [%y %ys] (if (pred y) {y @ys} ys)) {} xs))) @@ -231,13 +231,13 @@ ; Note. `foldr` is used in the definition of the list matcher. (define $foldr - (lambda [$fn $init $ls] + (lambda [$fn %init %ls] (match ls (list something) {[ init] [ (fn x (foldr fn init xs))]}))) (define $foldl - (lambda [$fn $init $ls] + (lambda [$fn %init %ls] (match ls (list something) {[ init] [ @@ -245,17 +245,17 @@ (seq z (foldl fn z xs)))]}))) (define $reduce - (lambda [$fn $ls] + (lambda [$fn %ls] (foldl fn (car ls) (cdr ls)))) (define $scanl - (lambda [$fn $init $ls] + (lambda [$fn %init %ls] {init @(match ls (list something) {[ {}] [ (scanl fn (fn init x) xs)]})})) (define $iterate - (lambda [$fn $x] + (lambda [$fn %x] (let* {[$nx1 (fn x)] [$nx2 (fn nx1)] [$nx3 (fn nx2)] @@ -263,13 +263,22 @@ [$nx5 (fn nx4)]} {x nx1 nx2 nx3 nx4 @(iterate fn nx5)}))) +(define $repeated-squaring + (lambda [$fn %x $n] + (match n integer + {[,1 x] + [?even? (let {[$y (repeated-squaring fn x (quotient n 2))]} + (fn y y))] + [?odd? (let {[$y (repeated-squaring fn x (quotient n 2))]} + (fn (fn y y) x))]}))) + (define $append (lambda [$xs $ys] {@xs @ys})) (define $concat (lambda [$xss] - (foldr (lambda [$xs $rs] {@xs @rs}) + (foldr (lambda [%xs %rs] {@xs @rs}) {} xss))) @@ -309,11 +318,11 @@ [hs {x @ms}]])]))))) (define $repeat - (lambda [$xs] + (lambda [%xs] {@xs @(repeat xs)})) (define $repeat1 - (lambda [$x] + (lambda [%x] {x @(repeat1 x)})) ;; @@ -522,6 +531,14 @@ (lambda [$a $xs] (let {[$us (unique/m a xs)]} (map (lambda [$u] [u (count/m a u xs)]) us)))) + +;; +;; Index +;; +(define $elemIndices + (lambda [$x $xs] + (match-all xs (list something) + [> (+ 1 (length hs))]))) ;;; ;;; Set diff --git a/lib/core/io.egi b/lib/core/io.egi --- a/lib/core/io.egi +++ b/lib/core/io.egi @@ -8,14 +8,14 @@ ;;; IO ;;; (define $print - (lambda [$x] + (procedure [$x] (do {[(write x)] [(write "\n")] [(flush)] }))) (define $print-to-port - (lambda [$port $x] + (procedure [$port $x] (do {[(write-to-port port x)] [(write-to-port port "\n")] }))) @@ -23,11 +23,11 @@ (define $display (compose show print)) (define $display-to-port - (lambda [$port $x] + (procedure [$port $x] (print-to-port port $ (show x)))) (define $each-line - (lambda [$proc] + (procedure [$proc] (do {[$eof (eof?)]} (if eof (return []) @@ -36,7 +36,7 @@ (each-line proc)))))) (define $each-line-from-port - (lambda [$port $proc] + (procedure [$port $proc] (do {[$eof (eof-port? port)]} (if eof (return []) @@ -45,7 +45,7 @@ (each-line-from-port port proc)))))) (define $each-file - (lambda [$files $proc] + (procedure [$files $proc] (match files (list string) {[ (return [])] [ @@ -58,9 +58,17 @@ ;;; Collection ;;; (define $each - (lambda [$proc $xs] + (procedure [$proc $xs] (match xs (list something) {[ (do {})] [ (do {[(proc x)]} (each proc rs))]}))) + +;;; +;;; Debug +;;; +(define $debug + (macro [$expr] + (io (do {[(print (show expr))]} + (return expr))))) diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -162,7 +162,7 @@ (define $regular-continued-fraction-of-sqrt-helper (lambda [$m $a $b] ; a+b*rt(m) - (let* {[$n (floor (+ (rtof a) (* (rtof b) (sqrt (rtof m)))))] + (let* {[$n (floor (f.+ (rtof a) (f.* (rtof b) (sqrt (rtof m)))))] [$x (- m (power n 2))]} (if (eq? x 0) {[a b n]} diff --git a/lib/core/shell.egi b/lib/core/shell.egi --- a/lib/core/shell.egi +++ b/lib/core/shell.egi @@ -55,4 +55,4 @@ })]} (return (read-tsv (S.intercalate "\t" (fn-c copts (fn-s sopts fs)))))))))) -(define $TSV.show (show-tsv $)) +(define $TSV.show show-tsv) diff --git a/lib/core/string.egi b/lib/core/string.egi --- a/lib/core/string.egi +++ b/lib/core/string.egi @@ -108,8 +108,8 @@ (define $alphabet? (lambda [$c] - (or (C.between? 'a' 'z' c) - (C.between? 'A' 'Z' c)))) + (or (C.between? c#a c#z c) + (C.between? c#A c#Z c)))) (define $alphabets? (lambda [$s] @@ -117,12 +117,12 @@ (define $upper-case (lambda [$c] - (if (C.between? 'a' 'z' c) + (if (C.between? c#a c#z c) (itoc (- (ctoi c) 32)) c))) (define $lower-case (lambda [$c] - (if (C.between? 'A' 'Z' c) + (if (C.between? c#A c#Z c) (itoc (+ (ctoi c) 32)) c))) diff --git a/lib/math/algebra/equations.egi b/lib/math/algebra/equations.egi --- a/lib/math/algebra/equations.egi +++ b/lib/math/algebra/equations.egi @@ -26,7 +26,7 @@ (define $q-f (lambda [$f $x] - (match (coefficients f x) (list math-expr) + (match (coefficients x f) (list math-expr) {[>>> (q-f' a_2 a_1 a_0)]}))) @@ -42,7 +42,7 @@ (define $c-f (lambda [$f $x] - (match (coefficients f x) (list math-expr) + (match (coefficients x f) (list math-expr) {[>>>> (c-f' a_3 a_2 a_1 a_0)]}))) @@ -50,13 +50,13 @@ (lambda [$a $b $c $d] (match [a b c d] [math-expr math-expr math-expr math-expr] {[[,1 ,0 $p $q] - (let {[[$u3 $v3] (q-f' 1 q (/ (* -1 p^3) 27))]} - [(+ (rt 3 u3) (rt 3 v3)) - (+ (* w (rt 3 u3)) (* w^2 (rt 3 v3))) - (+ (* w^2 (rt 3 u3)) (* w (rt 3 v3)))] - )] - [[,1 $a2 $a1 $a0] - (let {[[$y1 $y2 $y3] (c-f' 1 0 (- a1 (/ a2^2 3)) (+ a0 (* (/ -1 3) a1 a2) (* (/ 2 27) a2^3)))]} - [(- y1 (/ a2 3)) (- y2 (/ a2 3)) (- y3 (/ a2 3))] - )] + (let* {[[$s1 $s2] (2#[(rt 3 %1) (rt 3 %2)] (q-f' 1 (* 27 q) (* -27 p^3)))]} + [(/ (+ s1 s2) 3) ; r1 + (/ (+ (* w^2 s1) (* w s2)) 3) ; r2 + (/ (+ (* w s1) (* w^2 s2)) 3) ; r3 + ])] + [[,1 _ _ _] + (3#[(- %1 (/ b 3)) (- %2 (/ b 3)) (- %3 (/ b 3))] + (with-symbols {x y} + (c-f (substitute {[x (- y (/ b 3))]} (+ x^3 (* b x^2) (* c x) d)) y)))] [[_ _ _ _] (c-f' 1 (/ b a) (/ c a) (/ d a))]}))) diff --git a/lib/math/algebra/inverse.egi b/lib/math/algebra/inverse.egi --- a/lib/math/algebra/inverse.egi +++ b/lib/math/algebra/inverse.egi @@ -2,6 +2,12 @@ ;;;;; Inverse ;;;;; +(inverse (f x) x) +(f~-1 x) + +(inverse (** x 2) x) +;(sqrt x) + ; (inverse t (* a x^2) x) ; t = (* a x^2) ; x = (sqrt (/ t a)) @@ -27,18 +33,14 @@ [> (let {[$a (/ f (** x n))]} (inverse (/ t a) (/ f a) x))] - [_ (inverse' t f x)]})] + [_ (`inverse t f x)]})] [?polynomial? - (match (coefficients f x) (list math-expr) + (match (coefficients x f) (list math-expr) {[ >)> (inverse (/ (- t c) a) (** x (+ n 1)) x)] - [_ (inverse' t f x)]})] + [_ (`inverse t f x)]})] [_ (match f math-expr {[
(inverse (* p2 t) p1 x)]})] - [_ (inverse' t f x)]}))) - -(define $inverse' - (lambda [$t $f $x] - (to-math-expr ))) + [_ (`inverse t f x)]}))) diff --git a/lib/math/algebra/matrix.egi b/lib/math/algebra/matrix.egi new file mode 100644 --- /dev/null +++ b/lib/math/algebra/matrix.egi @@ -0,0 +1,145 @@ +;; +;; Matrices +;; + +(define $M.* + (cambda $ms + (foldl M.b.* (car ms) (cdr ms)))) + +(define $M.b.* + (lambda [%m1 %m2] + (with-symbols {j} + (. m1~#~j m2_j)))) + +(define $M.*' + (cambda $ms + (foldl M.b.*' (car ms) (cdr ms)))) + +(define $M.b.*' + (lambda [%m1 %m2] + (with-symbols {j} + (.' m1~#~j m2_j)))) + +(define $M.power + (lambda [%m $n] + (repeated-squaring M.* m n))) + +(define $M.comm + (lambda [%m1 %m2] + (with-symbols {i j k} + (- (. m1~i~j m2_j_k) (. m2~i~j m1_j_k))))) + +(define $M.inverse + (lambda [%m] + (match (tensor-size m) (list integer) + {[>> + (T.map (/ $ (M.det m)) (tensor {2 2} {m_2_2 (* -1 m_1_2) (* -1 m_2_1) m_1_1}))] + [_ undefined]}))) + +(define $trace (lambda [%t] (with-symbols {i} (contract + t~i_i)))) + +(define $matrix + (matcher + {[ [math-expr matrix matrix matrix] + {[$tgt (match (tensor-size tgt) (list integer) + {[> + {[tgt_1_1 tgt_1_[2 n] tgt_[2 m]_1 tgt_[2 m]_[2 n]]}] + [_ {}]})]}] + [,$val [] + {[$tgt (if (eq? val tgt) {[]} {})]}] + [$ [something] + {[$tgt {tgt}]}] + })) + +;; +;; Determinant +;; + +(define $even-and-odd-permutations + (lambda [$n] + (match n integer + {[,2 [{{1 2}} {{2 1}}]] + [_ (let* {[[$es $os] (even-and-odd-permutations (- n 1))] + [$es' (map 1#{@%1 n} es)] + [$os' (map 1#{@%1 n} os)]} + [{@es' + @(concat (map (lambda [$i] (map (permutate i n $) os')) (between 1 (- n 1)))) + } + {@os' + @(concat (map (lambda [$i] (map (permutate i n $) es')) (between 1 (- n 1)))) + } + ] + )]}))) + +(define $permutate + (lambda [$x $y $xs] + (match xs (list eq) + {[>>> + {@hs y @ms x @ts}] + [>>> + {@hs x @ms y @ts}]}))) + +(define $M.determinant + (lambda [%m] + (match (tensor-size m) (list integer) + {[>> + (let {[[$es $os] (even-and-odd-permutations n)]} + (- (sum (map (lambda [$e] + (product (map2 (lambda [$i $j] m_i_j) + (between 1 n) + e))) + es)) + (sum (map (lambda [$o] + (product (map2 (lambda [$i $j] m_i_j) + (between 1 n) + o))) + os))))] + [_ undefined]}))) + +(define $M.det M.determinant) + +;;; +;;; Eigenvalues and eigenvectors +;;; + +(define $M.eigenvalues + (lambda [%m] + (match (tensor-size m) (list integer) + {[>> + (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) + {[>> + (let {[[$e1 $e2] (q-f (M.det (T.- m (scalar-to-tensor x {2 2}))) x)]} + {[e1 (clear-index (T.- m (scalar-to-tensor e1 {2 2}))_i_1)] + [e2 (clear-index (T.- m (scalar-to-tensor e2 {2 2}))_i_1)]}) + ] + [_ undefined]}))) + +;; +;; LU decomposition +;; + +(define $M.LU + (lambda [%x] + (match (tensor-size x) (list integer) + {[>> + (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[ 0] [ 1] [ b_%1_%2]}) {2 2})] + [$U (generate-tensor 2#(match (compare %1 %2) ordering {[ 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)])] + [>> + (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[ 0] [ 1] [ b_%1_%2]}) {3 3})] + [$U (generate-tensor 2#(match (compare %1 %2) ordering {[ 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]}))) diff --git a/lib/math/algebra/root.egi b/lib/math/algebra/root.egi --- a/lib/math/algebra/root.egi +++ b/lib/math/algebra/root.egi @@ -13,37 +13,62 @@ (if (integer? n) (match x math-expr {[,0 0] - [?monomial? (rt' n x)] - [
> + [?monomial? (rt-monomial n x)] + [
> (let {[$xd (reduce gcd xs)] [$yd (reduce gcd ys)]} - (let {[[$a $r] (from-monomial (rt' n (/ xd yd)))]} + (let {[[$a $r] (from-monomial (rt-monomial n (/ xd yd)))]} (*' a (rt'' n (*' (** r n) (/' (sum' (map (/' $ xd) xs)) (sum' (map (/' $ yd) ys))))) )))]}) (rt'' n x)))) -(define $rt' +(define $rt-monomial (lambda [$n $x] + (/ (rt-term n (* (numerator x) + (** (denominator x) (- n 1)))) + (denominator x)))) + +(define $rt-term + (lambda [$n $x] + (match x term-expr + {[ + (if (lt? a 0) + (*' (rtm1 n) (rt-positive-term n (* -1 x))) + (rt-positive-term n x))]}))) + +(define $rt-positive-term + (lambda [$n $x] + (match [n x] [math-expr math-expr] + {[[,3 (* $a ,i $r)] (* -1 i (rt 3 (*' a r)))] + [[_ (* $a (,sqrt $b) $r)] (*' (rt (* n 2) (*' (**' a 2) b)) (rt n r))] + [[_ (* $a (,rt $n' $b) $r)] (*' (rt (* n n') (*' (**' a n') b)) (rt n r))] + [[_ _] (rt-positive-term1 n x)] + }))) + +(define $rt-positive-term1 + (lambda [$n $x] (letrec {[$f (lambda [$xs] - (match xs (assoc-multiset integer) + (match xs (assoc-multiset math-expr) {[ [1 1]] - [ - (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 - {[ - (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))))))) + [ + (let {[[$a $b] (f rs)]} + [(*' (**' p (quotient k n)) a) (*' (**' p (remainder k n)) b)])]}))] + [$g (lambda [$n $x] + (let {[$d (match x term-expr + {[ (gcd n (reduce gcd (map 2#%2 {@(to-assoc (p-f m)) @xs})))]})]} + (rt'' (/ n d) (rt d x))))]} + (match x term-expr + {[ + (match (f {@(to-assoc (p-f (abs m))) @xs}) [integer integer] + {[[$a ,1] a] + [[$a $b] (*' a (g n b))]})]})))) (define $rt'' (lambda [$n $x] (match [n x] [integer integer] - {[[,2 _] (to-math-expr' )] - [[_ _] (to-math-expr' )]}))) + {[[,2 _] (`sqrt x)] + [[_ _] (`rt n x)]}))) (define $rtm1 (lambda [$n] @@ -55,7 +80,7 @@ (define $sqrt (lambda [$x] - (if (number? x) + (if (scalar? x) (let {[$m (numerator x)] [$n (denominator x)]} (/ (rt 2 (* m n)) n)) @@ -75,6 +100,6 @@ [,2 -1] [,3 w] [,4 i] - [_ (to-math-expr' )] + [_ (`rtu n)] }) - (to-math-expr' )))) + (`rtu n)))) diff --git a/lib/math/algebra/tensor.egi b/lib/math/algebra/tensor.egi --- a/lib/math/algebra/tensor.egi +++ b/lib/math/algebra/tensor.egi @@ -4,160 +4,34 @@ ;;;;; ;;;;; -(define $T.map - (lambda [$fn $t] - (tensor-map fn t))) - -(define $T.map2 - (lambda [$fn $t1 $t2] - (tensor-map2 fn t1 t2))) - -(define $clear-index - (lambda [$t] - (| (tensor-size t) - (tensor-to-list t) |))) - (define $unit-tensor (lambda [$ns] (generate-tensor kronecker-delta ns))) (define $scalar-to-tensor (lambda [$x $ns] - (T.map (* x $) (unit-tensor ns)))) + (* x (unit-tensor ns)))) (define $zero-tensor (lambda [$ns] - (generate-tensor (cambda $ns 0) ns))) + (generate-tensor 1#0 ns))) -(define $T.unit (unit-tensor $)) -(define $T.zero (zero-tensor $)) +(define $b..' (lambda [%t1 %t2] (contract +' (*' t1 t2)))) +(define $b.. (lambda [%t1 %t2] (contract + (* t1 t2)))) -;; -;; Arithmetic -;; -(define $T.arith - (lambda [$op] - (lambda [$t1 $t2] - (match [(tensor? t1) (tensor? t2)] [bool bool] - {[[,#t ,#t] (T.map2 op t1 t2)] - [[,#t ,#f] (T.map2 op t1 (scalar-to-tensor t2 (tensor-size t1)))] - [[,#f ,#t] (T.map2 op (scalar-to-tensor t1 (tensor-size t2)) t2)] - })))) +(define $. + (cambda $xs + (match xs (list something) + {[> (capply `. xs)] + [_ (foldl b.. (car xs) (cdr xs))]}))) -(define $T.+ (T.arith +)) -(define $T.- (T.arith -)) +(define $T.+ + (lambda [%t1 %t2] + (tensor (tensor-size t1) + (map2 + (tensor-to-list t1) (tensor-to-list t2))))) -;; -;; Vectors -;; -(define $V.* - (lambda [$v1 $v2] - (. v1_i v2_i))) -;; -;; Matrices -;; -(define $M.* - (cambda $ms - (foldl M.*' (car ms) (cdr ms)))) - -(define $M.*' - (lambda [$m1 $m2] - (clear-index (. m1_i_j m2_j_k)))) - -(define $M.inverse - (lambda [$m] - (match (tensor-size m) (list integer) - {[>> - (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) - {[>> - (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[ 0] [ 1] [ b_%1_%2]}) {2 2})] - [$U (generate-tensor 2#(match (compare %1 %2) ordering {[ 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)])] - [>> - (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[ 0] [ 1] [ b_%1_%2]}) {3 3})] - [$U (generate-tensor 2#(match (compare %1 %2) ordering {[ 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) - {[>>> - {@hs y @ms x @ts}] - [>>> - {@hs x @ms y @ts}]}))) - -(define $M.determinant - (lambda [$m] - (match (tensor-size m) (list integer) - {[>> - (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) - {[>> - (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) - {[>> - (let {[[$e1 $e2] (q-f (M.det (T.- m (scalar-to-tensor x {2 2}))) x)]} - {[e1 (clear-index (T.- m (scalar-to-tensor e1 {2 2}))_i_1)] - [e2 (clear-index (T.- m (scalar-to-tensor e2 {2 2}))_i_1)]}) - ] - [_ undefined]}))) +(define $T.- + (lambda [%t1 %t2] + (tensor (tensor-size t1) + (map2 - (tensor-to-list t1) (tensor-to-list t2))))) diff --git a/lib/math/algebra/vector.egi b/lib/math/algebra/vector.egi new file mode 100644 --- /dev/null +++ b/lib/math/algebra/vector.egi @@ -0,0 +1,28 @@ +;; +;; Vectors +;; + +(define $dot-product + (lambda [%v1 %v2] + (with-symbols {i} + (. v1~i v2_i)))) + +(define $V.* dot-product) + +(define $cross-product/fn + (lambda [$fn %a %b] + [|(- (fn a_2 b_3) (fn a_3 b_2)) + (- (fn a_3 b_1) (fn a_1 b_3)) + (- (fn a_1 b_2) (fn a_2 b_1))|])) + +(define $cross-product + (lambda [%a %b] + (cross-product/fn * a b))) + +(define $div + (lambda [%A %xs] + (trace (∇ A xs)))) + +(define $rot + (lambda [%A %xs] + (cross-product/fn ∂/∂ A xs))) diff --git a/lib/math/analysis/derivative.egi b/lib/math/analysis/derivative.egi --- a/lib/math/analysis/derivative.egi +++ b/lib/math/analysis/derivative.egi @@ -4,52 +4,59 @@ ;;;;; ;;;;; -(define $d/d +(define $∂/∂ (lambda [$f $x] (match f math-expr - {[?simple-term? - (match [x f] [symbol-expr symbol-expr] - {[[ ] 0] - [[ ] 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 - {[> 0] - [>> (* n (** fx (- n 1)) (d/d fx x))] - [> - (+ (* 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 - {[ (sum (map (d/d $ x) ts))]})] - [_ - (match f math-expr - {[
- (let {[$p1' (d/d p1 x)] - [$p2' (d/d p2 x)]} - (/ (- (* p1' p2) (* p2' p1)) (** p2 2)))] - })] + {; symbol + [,x 1] + [?symbol? 0] + ; function application + [(,exp $g) (* (exp g) (∂/∂ g x))] + [(,log $g) (* (/ 1 g) (∂/∂ g x))] + [(,cos $g) (* (* -1 (sin g)) (∂/∂ g x))] + [(,sin $g) (* (cos g) (∂/∂ g x))] + [(,sqrt $g) (* (/ 1 (* 2 (sqrt g))) (∂/∂ g x))] + [(,** $g $h) (* f (∂/∂ (* (log g) h) x))] + [ + (sum (map 2#(* (capply `(add-subscript g %1) args) (∂/∂ %2 x)) + (zip nats args)))] + ; quote + [ (∂/∂ g x)] + ; term (constant) + [,0 0] + [(* _ ,1) 0] + ; term (multiplication) + [(* ,1 $fx^$n) (* n (** fx (- n 1)) (∂/∂ fx x))] + [(* $a $fx^$n $r) + (+ (* a (∂/∂ (**' fx n) x) r) + (* a (**' fx n) (∂/∂ r x)))] + ; polynomial + [ (sum (map (∂/∂ $ x) ts))] + ; quotient + [(/ $p1 $p2) + (let {[$p1' (∂/∂ p1 x)] + [$p2' (∂/∂ p2 x)]} + (/ (- (* p1' p2) (* p2' p1)) (** p2 2)))] }))) -(define $d/dx (d/d $ x)) ; just a syntax sugar -(define $d/dy (d/d $ y)) ; just a syntax sugar -(define $d/dz (d/d $ z)) ; just a syntax sugar +(define $d/d ∂/∂) +(define $pd/pd ∂/∂) +(define $∇ ∂/∂) +(define $nabla ∇) + +(define $grad ∇) + (define $taylor-expansion - (lambda [$f $x $a] - (map2 * - (map 1#(/ (** (- x a) %1) (fact %1)) nats0) - (map (substitute {[x a]} $) (iterate (d/d $ x) f))))) + (lambda [%f %xs %as] + (with-symbols {h} + (let {[$hs (generate-tensor 1#h_%1 (tensor-size xs))]} + (map2 * + (map 1#(/ 1 (fact %1)) nats0) + (map (compose (V.substitute xs as $) + (V.substitute hs (with-symbols {i} (- xs_i as_i)) $)) + (iterate (compose 1#(∇ %1 xs) 1#(V.* hs %1)) f))))))) -(define $maclaurin-expansion (taylor-expansion $ $ 0)) +(define $maclaurin-expansion + (lambda [%f %xs] + (multivariate-taylor-expansion f xs (tensor-map 1#0 xs)))) diff --git a/lib/math/analysis/integral.egi b/lib/math/analysis/integral.egi --- a/lib/math/analysis/integral.egi +++ b/lib/math/analysis/integral.egi @@ -7,41 +7,37 @@ (define $Sd (lambda [$x $f] (match f math-expr - {[?simple-term? - (match [x f] [symbol-expr symbol-expr] - {[[ ] (* f x)] - [[ ] (* (/ 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 - {[> - (let {[$b (foldl *' a (map 2#(**' %1 %2) ts))]} - (if (contain-symbol? x b) - (Sd' x f) - (/ (* b (** x (+ n 1))) (+ n 1))))] - [ - (let {[[$fxs $cs] (partition (contain-symbol? x $) (from-assoc ts))]} - (match fxs (list math-expr) - {[ (* f x)] - [> (* a (Sd x fx) (foldl *' 1 cs))] - [_ (Sd' x f)]}))]})] - [?polynomial? - (match f poly-expr - {[ (sum (map (Sd x $) ts))]})] - [_ - (match f math-expr - {[
- (match (coefficients p2 x) (list math-expr) - {[> (/ (Sd x p1) a)] - [_ (Sd' x f)]})]})] + {; symbols + [,x (* (/ 1 2) x^2)] + [ (* f x)] + ; function application + [(,exp ,x) (exp x)] + [(,cos ,x) (sin x)] + [(,sin ,x) (* -1 (cos x))] + [(,log ,x) (multSd x 1 (log x))] + [(,** $a ,x) (/ (** a x) (log a))] + [(,** $a $y) (with-symbols {t} + (substitute {[t y]} (Sd t (* (** a t) (d/d (inverse t y x) t)))))] + [(,Sd $y $g) (`Sd x (`Sd y g))] + [($f $y) (with-symbols {t} + (substitute {[t y]} (Sd t (* (f t) (d/d (inverse t y x) t)))))] + ; term (constant) + [,0 0] + [> (* c x)] + ; term (multiplication) + [> + (if (contain-symbol? x r) + (`Sd x f) + (* (/ a (+ n 1)) (** x (+ n 1)) r))] + ; polynomial + [ (sum (map (Sd x $) ts))] + ; quotient + [
$p2> + (sum (map 1#(Sd x (/ %1 p2)) ts))] + [
+ (if (contain-symbol? x p2) + (`Sd x f) + (/ (Sd x p1) p2))] }))) (define $multSd @@ -49,10 +45,6 @@ (let {[$F (Sd x f)]} (- (* F g) (Sd x (* F (d/d g x))))))) - -(define $Sd' - (lambda [$x $f] - (to-math-expr ))) (define $dSd (lambda [$x $a $b $f] diff --git a/lib/math/common/arithmetic.egi b/lib/math/common/arithmetic.egi --- a/lib/math/common/arithmetic.egi +++ b/lib/math/common/arithmetic.egi @@ -4,7 +4,7 @@ ;;;;; ;;;;; -(define $to-math-expr (macro [$arg] (math-normalize (apply to-math-expr' arg)))) +(define $to-math-expr (macro [$arg] (math-normalize b.+ 0 (apply to-math-expr' arg)))) (define $+' (cambda $xs (foldl b.+' (car xs) (cdr xs)))) (define $-' (cambda $xs (foldl b.-' (car xs) (cdr xs)))) @@ -12,18 +12,42 @@ (define $/' b./') (define $.' (cambda $xs (foldl b..' (car xs) (cdr xs)))) -(define $b.+ (macro [$x1 $x2] (math-normalize (b.+' x1 x2)))) -(define $b.- (macro [$x1 $x2] (math-normalize (b.-' x1 x2)))) -(define $b.* (macro [$x1 $x2] (math-normalize (b.*' x1 x2)))) -(define $b./ (macro [$x1 $x2] (math-normalize (b./' x1 x2)))) -(define $b.. (macro [$x1 $x2] (math-normalize (b..' x1 x2)))) +(define $b.+ + (lambda [$x1 $x2] + (match [x1 x2] [math-expr math-expr] + {[[
] + (b./ (b.+ p1 q1) p2)] + [[_ _] (reduce-fraction (math-normalize b.+' x1 x2))]}))) +(define $b.- + (lambda [$x1 $x2] + (match [x1 x2] [math-expr math-expr] + {[[
] + (b./ (b.- p1 q1) p2)] + [[_ _] (reduce-fraction (math-normalize b.-' x1 x2))]}))) + +(define $b.* + (lambda [$x1 $x2] + (reduce-fraction (math-normalize b.*' x1 x2)))) + +(define $b./ + (lambda [$x1 $x2] + (reduce-fraction (math-normalize b./' x1 x2)))) + (define $+ (cambda $xs (foldl b.+ (car xs) (cdr xs)))) (define $- (cambda $xs (foldl b.- (car xs) (cdr xs)))) (define $* (cambda $xs (foldl b.* (car xs) (cdr xs)))) (define $/ b./) -(define $. (cambda $xs (foldl b.. (car xs) (cdr xs)))) + +(define $reduce-fraction + (lambda [$mexpr] + (match mexpr math-expr + {[
+ > + (let {[$d (capply gcd {@ts2 @ts1})]} + (/' (sum' (map (/' $ d) ts1)) (sum' (map (/' $ d) ts2))))]}))) + (define $sum (lambda [$xs] (foldl + 0 xs))) @@ -56,19 +80,21 @@ (if (gte? n 0) (if (integer? n) (power x n) - (to-math-expr )) + (`** x n)) (/ 1 (** x (neg n)))) - (to-math-expr ))))) + (`** x n))))) (define $**' (lambda [$x $n] - (if (rational? n) - (if (gte? n 0) - (if (integer? n) - (power' x n) - (to-math-expr' )) - (/' 1 (**' x (neg n)))) - (to-math-expr' )))) + (if (eq? x e) + (exp n) + (if (rational? n) + (if (gte? n 0) + (if (integer? n) + (power' x n) + (`** x n)) + (/' 1 (**' x (neg n)))) + (`** x n))))) (define $gcd (cambda $xs @@ -81,13 +107,15 @@ (define $b.gcd (lambda [$x $y] (match [x y] [term-expr term-expr] - {[[ ] - (* (b.gcd' (abs a) (abs b)) (foldl *' 1 (map 2#(**' %1 %2) (AC.intersect xs ys))))]}))) + {[[_ ,0] x] + [[,0 _] y] + [[ ] + (*' (b.gcd' (abs a) (abs b)) (foldl *' 1 (map 2#(**' %1 %2) (AC.intersect xs ys))))]}))) (define $b.gcd' (lambda [$x $y] (match [x y] [integer integer] - {[[,0 _] y] - [[_ ,0] x] + {[[_ ,0] x] + [[,0 _] y] [[_ ?(gte? $ x)] (b.gcd' (modulo y x) x)] [[_ _] (b.gcd' y x)]}))) diff --git a/lib/math/common/constants.egi b/lib/math/common/constants.egi new file mode 100644 --- /dev/null +++ b/lib/math/common/constants.egi @@ -0,0 +1,7 @@ +;;;;; +;;;;; +;;;;; Mathematical Constants +;;;;; +;;;;; + +(define $pi π) diff --git a/lib/math/common/functions.egi b/lib/math/common/functions.egi --- a/lib/math/common/functions.egi +++ b/lib/math/common/functions.egi @@ -12,9 +12,9 @@ (match x term-expr {[,0 1] [,1 e] - [>>> (** -1 a)] - [_ (to-math-expr )]}) - (to-math-expr ))))) + [ (** -1 a)] + [_ (`exp x)]}) + (`exp x))))) (define $log (lambda [$x] @@ -23,7 +23,7 @@ (match x math-expr {[,1 0] [,e 1] - [_ (to-math-expr )]})))) + [_ (`log x)]})))) (define $cos (lambda [$x] @@ -31,8 +31,9 @@ (b.cos x) (match x math-expr {[,0 1] - [,(* 2 pi) 1] - [_ (to-math-expr )]})))) + [>> (** -1 (abs n))] + [
,2> 0] + [_ (`cos x)]})))) (define $sin (lambda [$x] @@ -40,7 +41,9 @@ (b.sin x) (match x math-expr {[,0 0] - [_ (to-math-expr )]})))) + [ 0] + [
,2> (** -1 (/ (- (abs n) 1) 2))] + [_ (`sin x)]})))) (define $tan (lambda [$x] @@ -48,7 +51,7 @@ (b.tan x) (match x math-expr {[,0 0] - [_ (to-math-expr )]})))) + [_ (`tan x)]})))) (define $cosh (lambda [$x] @@ -56,7 +59,7 @@ (b.cosh x) (match x math-expr {[,0 1] - [_ (to-math-expr )]})))) + [_ (`cosh x)]})))) (define $sinh (lambda [$x] @@ -64,7 +67,7 @@ (b.sinh x) (match x math-expr {[,0 0] - [_ (to-math-expr )]})))) + [_ (`sinh x)]})))) (define $tanh (lambda [$x] @@ -72,8 +75,7 @@ (b.tanh x) (match x math-expr {[,0 0] - [_ (to-math-expr )]})))) - + [_ (`tanh x)]})))) (define $sinc (lambda [$x] @@ -85,12 +87,16 @@ {[,0 1] [_ (/ (sin x) x)]})))) - (define $sigmoid (lambda [$z] (/ 1 (+ 1 (exp (* -1 z)))))) - (define $kronecker-delta (cambda $js (if (all (eq? $ (car js)) (cdr js)) 1 0))) + +(define $euler-totient-function + (lambda [$n] + (* n + (product (map (lambda [$p] (- 1 (/ 1 p))) + (unique (p-f n))))))) diff --git a/lib/math/expression.egi b/lib/math/expression.egi --- a/lib/math/expression.egi +++ b/lib/math/expression.egi @@ -11,145 +11,152 @@ {[]} {})]}] [$ [math-expr'] - {[
{
}] - [$tgt {(from-math-expr tgt)}]}] + {[$tgt {(from-math-expr tgt)}]}] })) (define $math-expr' (matcher - {[
[poly-expr poly-expr] + {[
[math-expr math-expr] {[
{[(to-math-expr' p1) (to-math-expr' p2)]}] [_ {}]}] + [ [(multiset math-expr)] + {[
@{}}>> {(map to-math-expr' ts)}] + [_ {}]}] + [ [plus-expr] + {[
@{}}>> {(to-math-expr'
}>>)}] + [_ {}]}] + [ [integer (assoc-multiset math-expr)] + {[
@{}}> @{}}>> {[n (map 2#[(to-math-expr' %1) %2] xs)]}] + [_ {}]}] + [ [integer mult-expr] + {[
@{}}> @{}}>> {[n (product' (map 2#(**' (to-math-expr' %1) %2) xs))]}] + [_ {}]}] + [ [eq] + {[
1] @{}}> @{}}> @{}}>> {v}] + [_ {}]}] + [ [eq (list index-expr)] + {[
1] @{}}> @{}}> @{}}>> {[v js]}] + [_ {}]}] + [ [eq (list math-expr)] + {[
1] @{}}> @{}}> + @{}}>> + {[v (map to-math-expr' mexprs)]}] + [_ {}]}] + [ [math-expr] + {[
1] @{}}> @{}}> + @{}}>> + {(to-math-expr' mexpr)}] + [_ {}]}] [$ [something] {[$tgt {(to-math-expr' tgt)}]}] })) -(define $poly-expr - (matcher - {[,$val [] - {[$tgt (if (eq? val tgt) - {[]} - {})]}] - [$ [poly-expr'] - {[ {}] - [
@{}}>> {}] - [$tgt {(from-math-expr tgt)}]}] - })) +(define $index-expr + (algebraic-data-matcher + { })) -(define $poly-expr' - (matcher - {[ [(multiset term-expr)] - {[ {(map to-math-expr' ts)}] - [
@{}}>> {(map to-math-expr' ts)}] - [_ {}]}] - [$ [something] - {[$tgt {(to-math-expr' tgt)}]}] - })) +(define $poly-expr math-expr) +(define $term-expr math-expr) +(define $symbol-expr math-expr) -(define $term-expr +(define $plus-expr (matcher - {[,$val [] - {[$tgt (if (eq? val tgt) + {[ [] + {[$tgt (if (eq? tgt 0) {[]} {})]}] - [ [term-expr] - {[$tgt (if (term? (/ tgt val)) - {(/ tgt val)} - {})]}] - [$ [term-expr'] - {[ {}] - [
@{}}> @{}}>> {}] - [$tgt {(from-math-expr tgt)}]}] - })) - -(define $term-expr' - (matcher - {[ [integer (assoc-multiset symbol-expr)] - {[ {[n (map 2#[(to-math-expr' %1) %2] xs)]}] - [
@{}}> @{}}>> {[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'] - {[ {}] - [
1] @{}}> @{}}> @{}}>> {}] - [ {}] - [
1] @{}}> @{}}> @{}}>> {}] - [$tgt {(from-math-expr tgt)}]}] + [ [math-expr plus-expr] + {[$tgt (match-all tgt math-expr + [> [t (sum' ts)]])]}] + [$ [math-expr] + {[$tgt {tgt}]}] })) -(define $symbol-expr' +(define $mult-expr (matcher - {[ [string] - {[ {v}] - [
1] @{}}> @{}}> @{}}>> {v}] - [_ {}]}] - [ [eq (list math-expr)] - {[ [v mexprs]] - [
1] @{}}> @{}}> - @{}}>> {[v (map to-math-expr' mexprs)]}] - [_ {}]}] - [$ [something] - {[$tgt {(to-math-expr' tgt)}]}] + {[ [] + {[$tgt (match tgt math-expr + {[,0 {[]}] + [_ {}]})]}] + [ [math-expr mult-expr] + {[$tgt (match tgt math-expr + {[ + (match-all xs (assoc-multiset math-expr) + [ + [x (product' (map 2#(**' %1 %2) rs))]])] + [_ {}]})]}] + [ [math-expr integer mult-expr] + {[$tgt (match tgt math-expr + {[ + (match-all xs (list [math-expr integer]) + [> + [x n (product' (map 2#(**' %1 %2) {@hs @ts}))]])] + [_ {}]})]}] + [$ [math-expr] + {[$tgt {tgt}]}] })) +;; +;; Predicate +;; (define $symbol? (lambda [$mexpr] (match mexpr math-expr - {[
>> >> - > >>> - #t] + {[ #t] [_ #f]}))) -(define $simple-term? +(define $tensor-symbol? (lambda [$mexpr] (match mexpr math-expr - {[
>> >> - > >>> - #t] - [,0 #t] + {[ ) _>>> #t] [_ #f]}))) +(define $apply? + (lambda [$mexpr] + (match mexpr math-expr + {[ #t] + [_ #f]}))) + +(define $simple-term? 1#(or (symbol? %1) (apply? %1))) + (define $term? (lambda [$mexpr] (match mexpr math-expr - {[
>> - > >>> - #t] + {[ #t] [,0 #t] [_ #f]}))) (define $polynomial? (lambda [$mexpr] (match mexpr math-expr - {[
> >>> - #t] + {[ #t] [,0 #t] [_ #f]}))) (define $monomial? (lambda [$mexpr] (match mexpr math-expr - {[
>> - >>> + {[
>> + >>> #t] [,0 #t] [_ #f]}))) +;; +;; Accessor +;; + +(define $symbol-indices + (lambda [$mexpr] + (match mexpr math-expr + {[ js] + [_ undefined]}))) + (define $from-monomial (lambda [$mexpr] (match mexpr math-expr - {[
>> - >>> + {[
+ > [(/ a b) (/ (foldl *' 1 (map 2#(**' %1 %2) xs)) (foldl *' 1 (map 2#(**' %1 %2) ys)))]]}))) @@ -157,10 +164,16 @@ ;; ;; Map ;; +(define $map-polys + (lambda [$fn $mexpr] + (match mexpr math-expr + {[
+ (/' (fn p1) (fn p2))]}))) + (define $map-terms (lambda [$fn $mexpr] (match mexpr math-expr - {[
> + {[
> (/' (foldl +' 0 (map fn ts1)) (foldl +' 0 (map fn ts2)))]}))) @@ -170,10 +183,13 @@ (match term term-expr {[ (*' a (foldl *' 1 (map 2#(match %1 symbol-expr - {[ (**' (fn %1) %2)] + {[ (**' (fn %1) %2)] [ - (** (fn (capply g (map (map-symbols fn $) args))) - %2) + (let {[$args'(map (map-symbols fn $) args)]} + (if (eq? args args') + (**' %1 %2) + (**' (fn (capply g args')) + %2))) ]}) xs)))]})) mexpr))) @@ -181,7 +197,7 @@ (define $contain-symbol? (lambda [$x $mexpr] (any id (match mexpr math-expr - {[
> + {[
> (map (lambda [$term] (match term term-expr {[ @@ -192,17 +208,50 @@ xs))]})) {@ts1 @ts2})]})))) +(define $contain-function? + (lambda [$f $mexpr] + (any id (match mexpr math-expr + {[
> + (map (lambda [$term] + (match term term-expr + {[ + (any id (map 2#(match %1 symbol-expr + {[ + (if (eq? f g) + #t + (any id (map (contain-function? f $) args)))] + [_ #f]}) + xs))]})) + {@ts1 @ts2})]})))) + +(define $contain-function-with-index? + (lambda [$mexpr] + (any id (match mexpr math-expr + {[
> + (map (lambda [$term] + (match term term-expr + {[ + (any id (map 2#(match %1 symbol-expr + {[ + (match f math-expr + {[> #t] + [_ (any id (map (contain-function-with-index? $) args))]})] + [ + (any id (map (contain-function-with-index? $) args))] + [_ #f]}) + xs))]})) + {@ts1 @ts2})]})))) + + ;;; ;;; Substitute ;;; (define $substitute (lambda [$ls $mexpr] - (if (tensor? mexpr) - (tensor-map (substitute ls $) mexpr) - (match ls (list [symbol-expr math-expr]) - {[ mexpr] - [ - (substitute rs (substitute' x a mexpr))]})))) + (match ls (list [symbol-expr math-expr]) + {[ mexpr] + [ + (substitute rs (substitute' x a mexpr))]}))) (define $substitute' (lambda [$x $a $mexpr] @@ -214,28 +263,32 @@ {[,x a] [_ sexpr]}))) +(define $V.substitute + (lambda [%xs %ys $mexpr] + (substitute (zip (tensor-to-list xs) (tensor-to-list ys)) mexpr))) + ;;; ;;; Coefficient ;;; (define $coefficients - (lambda [$f $x] + (lambda [$x $f] (let {[$m (capply max {0 @(match-all f math-expr - [
> _>> _> k])})]} - (map (coefficient f x $) (between 0 m))))) + [
> _>> _> k])})]} + (map (coefficient x $ f) (between 0 m))))) (define $coefficient - (lambda [$f $x $m] + (lambda [$x $m $f] (if (eq? m 0) (/ (sum (match-all f math-expr - [
$ts)> _>> _> + [
$ts)> _>> _> (foldl *' a (map 2#(**' %1 %2) ts))])) (denominator f)) - (coefficient' f x m)))) + (coefficient' x m f)))) (define $coefficient' - (lambda [$f $x $m] + (lambda [$x $m $f] (/ (sum (match-all f math-expr - [
> _>> _> + [
> _>> _> (if (eq? m k) (foldl *' a (map 2#(**' %1 %2) ts)) 0)])) diff --git a/lib/math/normalize.egi b/lib/math/normalize.egi --- a/lib/math/normalize.egi +++ b/lib/math/normalize.egi @@ -4,71 +4,185 @@ ;;;;; ;;;;; -;(set-term-rewriting-rule {[(rt $n $x)^,n x] -; [(* (sqrt $x) (sqrt $y)) (* (gcd x y) (sqrt (/ (* x y) (gcd x y))))] -; [(rtu $n)^,n 1] -; [w^3 1] -; [w^2 (- -1 w)] -; [i^2 -1]}) - (define $math-normalize - (lambda [$mexpr] - (if (tensor? mexpr) - (tensor-map math-normalize mexpr) - (if (number? mexpr) - (if (rational? mexpr) - mexpr - (map-terms rewrite-rule-rt - (map-terms rewrite-rule-sqrt - (map-terms rewrite-rule-rtu - (map-terms rewrite-rule-w - (map-terms rewrite-rule-i - mexpr - )))))) - mexpr)))) + (lambda [$fn $x1 $x2] + (if (and (integer? x1) (integer? x2)) + (fn x1 x2) + ((capply compose (map 2#%1 (filter 2#(%2 x1 x2) rewrite-rules))) (fn x1 x2))))) -(define $rewrite-rule-i +(define $rewrite-rules + { + [id 2##t] + [rewrite-rule-for-i 2#(and (contain-symbol? i %1) (contain-symbol? i %2))] + [rewrite-rule-for-w-term 2#(and (contain-symbol? w %1) (contain-symbol? w %2))] + [rewrite-rule-for-rtu-term 2#(and (contain-function? rtu %1) (contain-function? rtu %2))] + [rewrite-rule-for-w-poly 2#(and (contain-symbol? w %1) (contain-symbol? w %2))] + [rewrite-rule-for-rtu-poly 2#(and (contain-function? rtu %1) (contain-function? rtu %2))] + [rewrite-rule-for-sqrt 2#(and (contain-function? sqrt %1) (contain-function? sqrt %2))] + [rewrite-rule-for-rt 2#(and (contain-function? rt %1) (contain-function? rt %2))] + [rewrite-rule-for-cos-and-sin 2#(or (contain-function? cos %1) (contain-function? sin %1) (contain-function? cos %2) (contain-function? sin %2))] +; [rewrite-rule-for-∂/∂ 2#(and (contain-function-with-index? %1) (contain-function-with-index? %2))] + }) + +;; +;; i +;; + +(define $rewrite-rule-for-i rewrite-rule-for-i-term) + +(define $rewrite-rule-for-i-term (map-terms rewrite-rule-for-i-term' $)) + +(define $rewrite-rule-for-i-term' (lambda [$term] - (match term term-expr - {[> - (*' a (**' -1 (quotient k 2)) (foldl *' 1 (map 2#(**' %1 %2) ts)))] - [> - (*' a (**' -1 (quotient k 2)) i (foldl *' 1 (map 2#(**' %1 %2) ts)))] + (match term math-expr + {[(* $a ,i^(& ?even? $k) $r) + (*' a (**' -1 (quotient k 2)) r)] + [(* $a ,i^$k $r) + (*' a (**' -1 (quotient k 2)) r i)] [_ term]}))) -(define $rewrite-rule-w +;; +;; w +;; + +(define $rewrite-rule-for-w + (compose rewrite-rule-for-w-term + rewrite-rule-for-w-poly $)) + +(define $rewrite-rule-for-w-term (map-terms rewrite-rule-for-w-term' $)) +(define $rewrite-rule-for-w-poly (map-polys rewrite-rule-for-w-poly' $)) + +(define $rewrite-rule-for-w-term' (lambda [$term] - (match term term-expr - {[> - (*' a (**' w (remainder k 3)) (foldl *' 1 (map 2#(**' %1 %2) ts)))] - [> - (*' a (- -1 w) (foldl *' 1 (map 2#(**' %1 %2) ts)))] + (match term math-expr + {[(* $a ,w^(& ?(gte? $ 3) $k) $r) + (*' a r (**' w (remainder k 3)))] [_ term]}))) -(define $rewrite-rule-rtu +(define $rewrite-rule-for-w-poly' + (lambda [$poly] + (match poly math-expr + {[(+ (* $a ,w^,2 $mr) + (* $b ,w ,mr) + $pr) + (rewrite-rule-for-w-poly' (+' pr + (*' -1 a mr) + (*' (- b a) mr w) + ))] + [_ poly]}))) + +;; +;; rtu (include i and w) +;; + +(define $rewrite-rule-for-rtu + (compose + (map-terms rewrite-rule-for-rtu-term $) + (map-polys rewrite-rule-for-rtu-poly $) + )) + +(define $rewrite-rule-for-rtu-term (map-terms rewrite-rule-for-rtu-term' $)) +(define $rewrite-rule-for-rtu-poly (map-polys rewrite-rule-for-rtu-poly' $)) + +(define $rewrite-rule-for-rtu-term' (lambda [$term] - (match term term-expr - {[> - (*' a (**' (rtu n) (remainder k n)) (foldl *' 1 (map 2#(**' %1 %2) ts)))] + (match term math-expr + {[(* $a (,rtu $n)^(& ?(gte? $ n) $k) $r) + (*' a (**' (rtu n) (remainder k n)) r)] [_ term]}))) -(define $rewrite-rule-sqrt +(define $rewrite-rule-for-rtu-poly' + (lambda [$poly] + (match poly math-expr + {[(+ (* $a (,rtu $n)^,(- n 1) $mr) + (loop $i [2 ,(- n 1)] + (+ (* ,a ,(rtu n)^,(- n i) ,mr) ...) + $pr)) + (rewrite-rule-for-rtu-poly' (+' pr (*' -1 a mr)))] + [_ poly]}))) + +;; +;; sqrt +;; + +(define $rewrite-rule-for-sqrt (map-terms rewrite-rule-for-sqrt-term $)) + +(define $rewrite-rule-for-sqrt-term (lambda [$term] - (match term term-expr - {[>> - (* a x (foldl *' 1 (map 2#(**' %1 %2) ts)))] - [>> + (match term math-expr + {[(* $a (,sqrt $x) (,sqrt ,x) $r) + (rewrite-rule-for-sqrt-term (*' a x r))] + [(* $a (,sqrt (& ?term? $x)) (,sqrt (& ?term? $y)) $r) (let* {[$d (gcd x y)] [[$a1 $x1] (from-monomial (/ x d))] [[$a2 $y1] (from-monomial (/ y d))]} - (*' a d - (sqrt (*' a1 a2)) (sqrt x1) (sqrt y1) - (foldl *' 1 (map 2#(**' %1 %2) ts))))] + (*' a d + (sqrt (*' a1 a2)) (sqrt x1) (sqrt y1) + r))] [_ term]}))) -(define $rewrite-rule-rt +;; +;; rt (include sqrt) +;; + +(define $rewrite-rule-for-rt + (map-terms rewrite-rule-for-rt-term $)) + +(define $rewrite-rule-for-rt-term (lambda [$term] - (match term term-expr - {[> - (*' a (**' x (quotient k n)) (**' (rt n x) (remainder k n)) (foldl *' 1 (map 2#(**' %1 %2) ts)))] + (match term math-expr + {[(* $a (,rt $n $x)^(& ?(gte? $ n) $k) $r) + (*' a (**' x (quotient k n)) (**' (rt n x) (remainder k n)) r)] [_ term]}))) + +;; +;; cos, sin +;; + +(define $rewrite-rule-for-cos-and-sin (map-polys rewrite-rule-for-cos-and-sin-poly $)) + +(define $rewrite-rule-for-cos-and-sin-poly + (lambda [$poly] + (match poly math-expr + {[(+ (* $a (,cos $θ)^,2 $mr) + (* ,a (,sin ,θ)^,2 ,mr) + $pr) + (rewrite-rule-for-cos-and-sin-poly (+' pr (*' a mr)))] + [(+ (* $a $mr) + (* ,(*' -1 a) (,sin $θ)^,2 ,mr) + $pr) + (rewrite-rule-for-cos-and-sin-poly (+' (*' a (cos θ)^2 mr)))] + [(+ (* $a $mr) + (* ,(*' -1 a) (,cos $θ)^,2 ,mr) + $pr) + (rewrite-rule-for-cos-and-sin-poly (+' (*' a (sin θ)^2)))] + [_ poly]}))) + +;; +;; d +;; + +(define $rewrite-rule-for-d (map-terms rewrite-rule-for-d-term $)) + +(define $rewrite-rule-for-d-term + (lambda [$term] + (match term math-expr + {[(* _ (,d _) (,d _) _) + 0] + [_ term]}))) + +;; +;; ∂/∂ +;; + +(define $rewrite-rule-for-∂/∂ (map-polys rewrite-rule-for-∂/∂-poly $)) + +(define $rewrite-rule-for-∂/∂-poly + (lambda [$poly] + (match poly math-expr + {[(+ (* $a ) $args>^$n $mr) + (* $b ,args>^,n ,mr) + $pr) + (+ (* (+ a b) (`g args)^n mr) + pr)] + [_ poly]}))) diff --git a/test/UnitTest.hs b/test/UnitTest.hs --- a/test/UnitTest.hs +++ b/test/UnitTest.hs @@ -31,7 +31,7 @@ assertEgisonM m = fromEgisonM m >>= assertString . either show (const "") collectDefsAndTests (Define name expr) (bindings, tests) = - ((name, expr) : bindings, tests) + ((show name, expr) : bindings, tests) collectDefsAndTests (Test expr) (bindings, tests) = (bindings, expr : tests) collectDefsAndTests _ r = r