diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,6 +1,28 @@ # Changelog ## Latest +### New Features +* Added binary function notation for arbitrary 2-ary functions. ([#260](https://github.com/egison/egison/pull/260)) +```hs +> let mod x y := x % y in 103 `mod` 10 +3 +``` + +### Backward-incompatible Changes +* Swapped the notation for `QuoteExpr` and `QuoteSymbolExpr`. ([#262](https://github.com/egison/egison/issues/262)) +```hs +> `(a + b) + `(a + b) -- QuoteExpr, which prevents (a + b) from unpacking +2 * '(a + b) +> 'exp x -- QuoteSymbolExpr +exp x +``` +* Changed the specification of `generateTensor` so that the generation function takes indices as a collection. ([#267](https://github.com/egison/egison/pull/267)) + +## 4.1.2 +* Nothing changed (bumped version of `sweet-egison` package) + +## 4.1.1 +* Fix compilation issue with GHC 8.10 ([#248](https://github.com/egison/egison/issues/248)) ## 4.1.0 ### New Features diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,5 @@ #!/usr/bin/env runhaskell -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 4.1.2 +Version: 4.1.3 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. @@ -84,30 +84,26 @@ Library default-language: Haskell2010 Build-Depends: - base >= 4.7 && < 5 - , array - , random - , containers - , unordered-containers - , haskeline - , transformers - , mtl >=2.2.1 - , parsec >= 3.0 - , megaparsec >= 7.0.0 - , parser-combinators - , directory - , ghc - , ghc-paths - , text - , regex-tdfa - , process - , vector - , split - , hashable - , optparse-applicative - , prettyprinter - , unicode-show - , sweet-egison >= 0.1.1.3 + base >= 4.8 && < 5 + , random == 1.* + , containers == 0.6.* + , unordered-containers >= 0.1.0.0 && < 0.3 + , haskeline >= 0.7 && < 0.9 + , transformers >= 0.4 && < 0.6 + , mtl >= 2.2.2 && < 3.0 + , parsec >= 3.0 + , megaparsec >= 7.0.0 && < 12.0 + , parser-combinators >= 1.0 && < 2.0 + , directory >= 1.3.0 + , text >= 0.2 && < 1.3 + , regex-tdfa >= 1.2.0 + , process >= 1.0 && < 2.0 + , vector == 0.12.* + , hashable >= 1.0 && < 2.0 + , optparse-applicative >= 0.14 && < 0.20 + , prettyprinter >= 1.0 && < 2.0 + , unicode-show == 0.1.* + , sweet-egison == 0.1.1.3 if !impl(ghc > 8.0) Build-Depends: fail Hs-Source-Dirs: hs-src @@ -160,7 +156,7 @@ Main-Is: Test.hs Build-Depends: egison - , base >= 4.0 && < 5 + , base >= 4.8 && < 5 , transformers , mtl , Glob @@ -176,10 +172,10 @@ default-language: Haskell2010 Type: exitcode-stdio-1.0 Hs-Source-Dirs: test - Main-Is: OptionsTest.hs + Main-Is: CLITest.hs Build-Depends: egison - , base >= 4.0 && < 5 + , base >= 4.8 && < 5 , process , HUnit , test-framework @@ -195,7 +191,7 @@ Main-Is: Benchmark.hs Build-Depends: egison - , base >= 4.0 && < 5 + , base >= 4.8 && < 5 , criterion >= 0.5 , transformers Other-modules: Paths_egison @@ -208,22 +204,13 @@ Build-depends: egison , base >= 4.0 && < 5 - , array - , containers , exceptions - , unordered-containers , haskeline - , transformers , mtl - , parsec >= 3.1 , directory - , ghc - , ghc-paths , filepath , text - , process , regex-tdfa - , vector , optparse-applicative if !impl(ghc > 8.0) Build-Depends: semigroups @@ -237,8 +224,7 @@ Main-is: translator.hs Build-depends: egison - , base >= 4.0 && < 5 + , base >= 4.8 && < 5 , prettyprinter - , split Hs-Source-Dirs: hs-src/Tool ghc-options: -Wall -Wno-name-shadowing 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} module Main where @@ -12,8 +12,7 @@ import Data.Version -import System.Console.Haskeline (InputT, getInputLine, getHistory, putHistory, - runInputT, Settings (..)) +import System.Console.Haskeline (InputT, Settings (..), getHistory, getInputLine, putHistory, runInputT) import System.Console.Haskeline.History (addHistoryUnlessConsecutiveDupe) import System.Directory (getHomeDirectory) import System.Exit (exitFailure, exitSuccess) @@ -31,7 +30,7 @@ isInValidMathOption :: EgisonOpts -> Bool isInValidMathOption EgisonOpts{ optMathExpr = Just lang } = lang `notElem` ["asciimath", "latex", "mathematica", "maxima", "haskell"] -isInValidMathOption EgisonOpts{ optMathExpr = Nothing } = False +isInValidMathOption EgisonOpts{ optMathExpr = Nothing } = False runWithOptions :: EgisonOpts -> IO () runWithOptions opts | isInValidMathOption opts = @@ -46,7 +45,7 @@ coreEnv <- initialEnv mEnv <- fromEvalT $ evalTopExprs coreEnv $ map Load (optLoadLibs opts) ++ map LoadFile (optLoadFiles opts) case mEnv of - Left err -> liftIO $ print err + Left err -> liftIO $ print err Right env -> handleOption env opts handleOption :: Env -> EgisonOpts -> RuntimeM () @@ -133,7 +132,7 @@ Just topExpr -> do result <- fromEvalT (evalTopExprStr env topExpr) case result of - Left err -> liftIO (print err) >> repl env + Left err -> liftIO (print err) >> repl env Right (Just str, env') -> liftIO (putStrLn str) >> repl env' Right (Nothing, env') -> repl env' ) @@ -162,7 +161,7 @@ history <- getHistory putHistory $ addHistoryUnlessConsecutiveDupe line history let input = prev ++ line - parsedExpr <- lift $ parseTopExpr input + parsedExpr <- lift $ parseTopExpr (replaceNewLine input) case parsedExpr of Left err | err =~ "unexpected end of input" -> getEgisonExpr' (input ++ "\n") @@ -172,3 +171,10 @@ Right topExpr -> do -- outputStr $ show topExpr return $ Just topExpr + +replaceNewLine :: String -> String +replaceNewLine input = + let (before, _, after) = input =~ "#newline" :: (String, String, String) in + case after of + "" -> before + _ -> before ++ "\n" ++ replaceNewLine after 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 @@ -20,11 +20,11 @@ , version ) where -import Control.Monad.Reader (asks, local) +import Control.Monad.Reader (asks, local) import Control.Monad.State import Data.Version -import qualified Paths_egison as P +import qualified Paths_egison as P import Language.Egison.AST import Language.Egison.CmdOptions @@ -59,10 +59,10 @@ [ "lib/core/base.egi" -- Defines (&&) (||) , "lib/math/common/arithmetic.egi" -- Defines (+) (-) (*) (/) (+') (-') (*') (/') , "lib/math/algebra/tensor.egi" -- Defines (.) (.') + , "lib/core/collection.egi" -- Defines (++) for patterns , "lib/math/expression.egi" -- Defines (+) (*) (/) (^) for patterns , "lib/core/assoc.egi" - , "lib/core/collection.egi" , "lib/core/io.egi" , "lib/core/maybe.egi" , "lib/core/number.egi" diff --git a/hs-src/Language/Egison/AST.hs b/hs-src/Language/Egison/AST.hs --- a/hs-src/Language/Egison/AST.hs +++ b/hs-src/Language/Egison/AST.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveTraversable #-} {- | Module : Language.Egison.AST @@ -33,11 +32,12 @@ , reservedPatternOp , findOpFrom , stringToVarWithIndices + , extractNameFromVarWithIndices ) where -import Data.List (find) -import Data.Maybe (fromJust) -import Data.Text (Text) +import Data.List (find) +import Data.Maybe (fromJust) +import Data.Text (Text) data TopExpr = Define VarWithIndices Expr @@ -75,7 +75,7 @@ | VectorExpr [Expr] | LambdaExpr [Arg ArgPattern] Expr - | LambdaExpr' [Arg String] Expr + | LambdaExpr' [Arg VarWithIndices] Expr | MemoizedLambdaExpr [String] Expr | CambdaExpr String Expr | PatternFunctionExpr [String] Pattern @@ -107,6 +107,8 @@ | ApplyExpr Expr [Expr] | CApplyExpr Expr Expr | AnonParamFuncExpr Integer Expr + | AnonTupleParamFuncExpr Integer Expr + | AnonListParamFuncExpr Integer Expr | AnonParamExpr Integer | GenerateTensorExpr Expr Expr @@ -121,7 +123,7 @@ deriving Show data VarWithIndices = VarWithIndices String [VarIndex] - deriving Show + deriving (Show, Eq) data Arg a = ScalarArg a @@ -131,21 +133,23 @@ data ArgPattern = APWildCard - | APPatVar String + | APPatVar VarWithIndices | APInductivePat String [Arg ArgPattern] | APTuplePat [Arg ArgPattern] | APEmptyPat - | APConsPat (Arg ArgPattern) (Arg ArgPattern) - | APSnocPat (Arg ArgPattern) (Arg ArgPattern) + | APConsPat (Arg ArgPattern) ArgPattern + | APSnocPat ArgPattern (Arg ArgPattern) deriving Show data VarIndex = VSubscript String | VSuperscript String + | VMultiSubscript String Integer String -- _(a_1)..._(a_n) -> VMultiSubscript "a" 1 "n" + | VMultiSuperscript String Integer String -- ~(a_1)...~(a_n) -> VMultiSuperscript "a" 1 "n" | VGroupScripts [VarIndex] | VSymmScripts [VarIndex] | VAntiSymmScripts [VarIndex] - deriving Show + deriving (Show, Eq) data IndexExpr a = Subscript a @@ -256,8 +260,7 @@ reservedPatternOp :: [Op] reservedPatternOp = - [ Op "::" 5 InfixR False -- cons (desugared) - , Op "++" 5 InfixR False -- join (desugared) + [ Op "::" 5 InfixR False -- required for desugaring collection pattern , Op "&" 3 InfixR False , Op "|" 2 InfixR False ] @@ -265,8 +268,12 @@ findOpFrom :: String -> [Op] -> Op findOpFrom op table = fromJust $ find ((== op) . repr) table +makeApply :: String -> [Expr] -> Expr +makeApply func args = ApplyExpr (VarExpr func) args + stringToVarWithIndices :: String -> VarWithIndices stringToVarWithIndices name = VarWithIndices name [] -makeApply :: String -> [Expr] -> Expr -makeApply func args = ApplyExpr (VarExpr func) args +extractNameFromVarWithIndices :: VarWithIndices -> String +extractNameFromVarWithIndices (VarWithIndices name _) = name + diff --git a/hs-src/Language/Egison/CmdOptions.hs b/hs-src/Language/Egison/CmdOptions.hs --- a/hs-src/Language/Egison/CmdOptions.hs +++ b/hs-src/Language/Egison/CmdOptions.hs @@ -15,7 +15,7 @@ import Data.List (intercalate) import Data.Maybe (maybeToList) import Options.Applicative -import qualified Text.Parsec as P +import qualified Text.Parsec as P data EgisonOpts = EgisonOpts { optExecFile :: Maybe (String, [String]), diff --git a/hs-src/Language/Egison/Completion.hs b/hs-src/Language/Egison/Completion.hs --- a/hs-src/Language/Egison/Completion.hs +++ b/hs-src/Language/Egison/Completion.hs @@ -15,7 +15,7 @@ import Language.Egison.Data (Env (..)) import Language.Egison.IExpr (Var (..)) -import Language.Egison.Parser.NonS (upperReservedWords, lowerReservedWords) +import Language.Egison.Parser.NonS (lowerReservedWords, upperReservedWords) -- |Complete Egison keywords completeEgison :: Monad m => Env -> CompletionFunc m @@ -52,12 +52,12 @@ closeParen str = closeParen' 0 $ removeCharAndStringLiteral str removeCharAndStringLiteral :: String -> String -removeCharAndStringLiteral [] = [] -removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':removeCharAndStringLiteral str -removeCharAndStringLiteral ('"':str) = removeCharAndStringLiteral' str +removeCharAndStringLiteral [] = [] +removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':removeCharAndStringLiteral str +removeCharAndStringLiteral ('"':str) = removeCharAndStringLiteral' str removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':removeCharAndStringLiteral str -removeCharAndStringLiteral ('\'':str) = removeCharAndStringLiteral' str -removeCharAndStringLiteral (c:str) = c:removeCharAndStringLiteral str +removeCharAndStringLiteral ('\'':str) = removeCharAndStringLiteral' str +removeCharAndStringLiteral (c:str) = c:removeCharAndStringLiteral str removeCharAndStringLiteral' :: String -> String removeCharAndStringLiteral' [] = [] 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 @@ -1,7 +1,7 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Language.Egison.Core @@ -22,36 +22,35 @@ , patternMatch ) where -import Prelude hiding (mapM, mappend, mconcat) +import Prelude hiding (mapM, mappend, mconcat) import Control.Arrow -import Control.Monad.Except (throwError) -import Control.Monad.State hiding (mapM, join) +import Control.Monad.Except (throwError) +import Control.Monad.State hiding (join, mapM) import Control.Monad.Trans.Maybe -import Data.Char (isUpper) -import Data.Foldable (toList) +import Data.Char (isUpper) +import Data.Foldable (toList) import Data.IORef -import Data.List (partition) +import Data.List (partition) import Data.Maybe -import qualified Data.Sequence as Sq -import Data.Traversable (mapM) +import qualified Data.Sequence as Sq +import Data.Traversable (mapM) -import qualified Data.HashMap.Lazy as HL -import qualified Data.Vector as V +import qualified Data.HashMap.Lazy as HL +import qualified Data.Vector as V import Language.Egison.Data import Language.Egison.Data.Collection import Language.Egison.Data.Utils -import Language.Egison.EvalState (MonadEval(..), mLabelFuncName) +import Language.Egison.EvalState (MonadEval (..), mLabelFuncName) import Language.Egison.IExpr +import Language.Egison.MList import Language.Egison.Match import Language.Egison.Math -import Language.Egison.MList import Language.Egison.RState import Language.Egison.Tensor - evalConstant :: ConstantExpr -> EgisonValue evalConstant (CharExpr c) = Char c evalConstant (StringExpr s) = toEgison s @@ -68,14 +67,14 @@ whnf <- evalExprShallow env expr case whnf of Value (ScalarData s) -> return . Value . ScalarData $ SingleTerm 1 [(Quote s, 1)] - _ -> throwError =<< TypeMismatch "scalar in quote" whnf <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "scalar in quote" whnf) evalExprShallow env (IQuoteSymbolExpr expr) = do whnf <- evalExprShallow env expr case whnf of - Value (Func (Just name) _ _ _) -> return . Value $ symbolScalarData "" name - Value (ScalarData _) -> return whnf - _ -> throwError =<< TypeMismatch "value in quote-function" whnf <$> getFuncNameStack + Value (Func (Just (Var name [])) _ _ _) -> return . Value $ symbolScalarData "" name + Value (ScalarData _) -> return whnf + _ -> throwErrorWithTrace (TypeMismatch "value in quote-function" whnf) evalExprShallow env (IVarExpr name) = case refVar env (Var name []) of @@ -107,35 +106,19 @@ innersSeq <- liftIO $ newIORef $ Sq.fromList [ISubCollection xs', ISubCollection ys'] return $ ICollection innersSeq -evalExprShallow env@(Env frame maybe_vwi) (IVectorExpr exprs) = do +evalExprShallow env (IVectorExpr exprs) = do let n = toInteger (length exprs) - whnfs <- zipWithM evalWithIndex exprs [1..] + whnfs <- mapM (evalExprShallow env) exprs case whnfs of ITensor Tensor{}:_ -> - zipWithM f whnfs [1..] >>= tConcat' >>= fromTensor + mapM f whnfs >>= tConcat' >>= fromTensor _ -> makeITensorFromWHNF [n] whnfs where - evalWithIndex :: IExpr -> Integer -> EvalM WHNFData - evalWithIndex expr index = evalExprShallow env' expr - where - env' = case maybe_vwi of - Nothing -> env - Just (name, indices) -> - Env frame (Just (name, zipWith changeIndex indices [toEgison index])) - f (ITensor (Tensor ns xs indices)) i = do - xs <- mapM evalRef xs - let xs' = V.zipWith g xs $ V.fromList (map (\ms -> map toEgison (i:ms)) $ enumTensorIndices ns) - xs' <- mapM newEvaluatedObjectRef xs' - return $ Tensor ns xs' indices - f x _ = Scalar <$> newEvaluatedObjectRef x - g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p))) ms = - Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p)) - where - fn' = case maybe_vwi of - Nothing -> fn - Just (name, indices) -> - symbolScalarData' (name ++ concatMap show (zipWith changeIndex indices ms)) - g x _ = x + f (ITensor (Tensor ns xs indices)) = do + xs' <- mapM evalRef xs + xs'' <- mapM newEvaluatedObjectRef xs' + return $ Tensor ns xs'' indices + f x = Scalar <$> newEvaluatedObjectRef x evalExprShallow env (ITensorExpr nsExpr xsExpr) = do nsWhnf <- evalExprShallow env nsExpr @@ -144,7 +127,7 @@ xs <- collectionToRefs xsWhnf >>= fromMList >>= mapM evalRef if product ns == toInteger (length xs) then makeITensorFromWHNF ns xs - else throwError =<< InconsistentTensorShape <$> getFuncNameStack + else throwErrorWithTrace InconsistentTensorShape evalExprShallow env (IHashExpr assocs) = do let (keyExprs, exprs) = unzip assocs @@ -168,22 +151,27 @@ ScalarData _ -> IntKey <$> fromEgison val Char c -> return (CharKey c) String str -> return (StrKey str) - _ -> throwError =<< TypeMismatch "integer or string" (Value val) <$> getFuncNameStack - makeHashKey whnf = throwError =<< TypeMismatch "integer or string" whnf <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "integer or string" (Value val)) + makeHashKey whnf = throwErrorWithTrace (TypeMismatch "integer or string" whnf) -evalExprShallow env (IIndexedExpr override expr indices) = do +evalExprShallow env@(Env fs _) (IIndexedExpr override expr indices) = do -- Tensor or hash - tensor <- case expr of - IVarExpr xs -> do - let mObjRef = refVar env (Var xs (map (const () <$>) indices)) + whnf <- case expr of + IVarExpr v -> do + let mObjRef = refVar env (Var v (map (fmap (const Nothing)) indices)) case mObjRef of Just objRef -> evalRef objRef Nothing -> evalExprShallow env expr _ -> evalExprShallow env expr - case tensor of + case whnf of Value (ScalarData (SingleTerm 1 [(Symbol id name js', 1)])) -> do js2 <- mapM evalIndexToScalar indices return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (js' ++ js2), 1)])) + Value (Func v@(Just (Var fnName is)) env args body) -> do + js <- mapM evalIndex indices + frame <- pmIndices is js + let env' = extendEnv env frame + return $ Value (Func v env' args body) Value (TensorData t@Tensor{}) -> do js <- mapM evalIndex indices Value <$> refTensorWithOverride override js t @@ -192,7 +180,7 @@ refTensorWithOverride override js t _ -> do js <- mapM evalIndex indices - refHash tensor (map extractIndex js) + refHash whnf (map extractIndex js) where evalIndex :: Index IExpr -> EvalM (Index EgisonValue) evalIndex index = traverse (evalExprDeep env) index @@ -204,7 +192,7 @@ js <- map Sub <$> (evalExprDeep env jsExpr >>= collectionToList) tensor <- case expr of IVarExpr xs -> do - let mObjRef = refVar env (Var xs (map (\_ -> Sub ()) js)) + let mObjRef = refVar env (Var xs (map (\_ -> Sub Nothing) js)) case mObjRef of Just objRef -> evalRef objRef Nothing -> evalExprShallow env expr @@ -213,13 +201,13 @@ Value (ScalarData _) -> return tensor Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t ITensor t@Tensor{} -> refTensorWithOverride override js t - _ -> throwError =<< NotImplemented "subrefs" <$> getFuncNameStack + _ -> throwErrorWithTrace (NotImplemented "subrefs") evalExprShallow env (ISuprefsExpr override expr jsExpr) = do js <- map Sup <$> (evalExprDeep env jsExpr >>= collectionToList) tensor <- case expr of IVarExpr xs -> do - let mObjRef = refVar env (Var xs (map (\_ -> Sup ()) js)) + let mObjRef = refVar env (Var xs (map (\_ -> Sup Nothing) js)) case mObjRef of Just objRef -> evalRef objRef Nothing -> evalExprShallow env expr @@ -228,7 +216,7 @@ Value (ScalarData _) -> return tensor Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t ITensor t@Tensor{} -> refTensorWithOverride override js t - _ -> throwError =<< NotImplemented "suprefs" <$> getFuncNameStack + _ -> throwErrorWithTrace (NotImplemented "suprefs") evalExprShallow env (IUserrefsExpr _ expr jsExpr) = do val <- evalExprDeep env expr @@ -236,12 +224,16 @@ case val of ScalarData (SingleTerm 1 [(Symbol id name is, 1)]) -> return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (is ++ js), 1)])) - ScalarData (SingleTerm 1 [(FunctionData name argnames args is, 1)]) -> - return $ Value (ScalarData (SingleTerm 1 [(FunctionData name argnames args (is ++ js), 1)])) - _ -> throwError =<< NotImplemented "user-refs" <$> getFuncNameStack + ScalarData (SingleTerm 1 [(FunctionData sym argnames args, 1)]) -> + case sym of + SingleTerm 1 [(Symbol id name is, 1)] -> do + let sym' = SingleTerm 1 [(Symbol id name (is ++ js), 1)] + return $ Value (ScalarData (SingleTerm 1 [(FunctionData sym' argnames args, 1)])) + _ -> throwErrorWithTrace (NotImplemented "user-refs") + _ -> throwErrorWithTrace (NotImplemented "user-refs") -evalExprShallow env (ILambdaExpr fnname names expr) = do - return . Value $ Func fnname env names expr +evalExprShallow env (ILambdaExpr vwi names expr) = do + return . Value $ Func vwi env names expr evalExprShallow env (IMemoizedLambdaExpr names body) = do hashRef <- liftIO $ newIORef HL.empty @@ -255,7 +247,15 @@ evalExprShallow env@(Env _ (Just (name, is))) (IFunctionExpr args) = do args' <- mapM (evalExprDeep env . IVarExpr) args >>= mapM extractScalar - return . Value $ ScalarData (SingleTerm 1 [(FunctionData (symbolScalarData' (name ++ concatMap show is)) (map symbolScalarData' args) args' [], 1)]) + is' <- mapM unwrapMaybeFromIndex is + return . Value $ ScalarData (SingleTerm 1 [(FunctionData (SingleTerm 1 [(Symbol "" name is', 1)]) (map symbolScalarData' args) args', 1)]) + where + unwrapMaybeFromIndex :: Index (Maybe ScalarData) -> EvalM (Index ScalarData) -- Maybe we can refactor this function +-- unwrapMaybeFromIndex = return . (fmap fromJust) + unwrapMaybeFromIndex (Sub Nothing) = throwError $ Default "function symbol can be used only with generateTensor" + unwrapMaybeFromIndex (Sup Nothing) = throwError $ Default "function symbol can be used only with generateTensor" + unwrapMaybeFromIndex (Sub (Just i)) = return (Sub i) + unwrapMaybeFromIndex (Sup (Just i)) = return (Sup i) evalExprShallow env (IIfExpr test expr expr') = do test <- evalExprDeep env test >>= fromEgison @@ -267,7 +267,7 @@ where extractBindings :: IBindingExpr -> EvalM [Binding] extractBindings (PDPatVar var, expr) = - makeBindings [var] . (:[]) <$> newThunkRef (memorizeVarInEnv env var) expr + newThunkRef (memorizeVarInEnv env var) expr >>= makeBindings [var] . (:[]) extractBindings (pdp, expr) = do thunk <- newThunkRef env expr bindPrimitiveDataPattern pdp thunk @@ -314,7 +314,7 @@ evalExprShallow env (IDoExpr bindings expr) = return $ Value $ IOFunc $ do let body = foldr genLet (IApplyExpr expr [IVarExpr "#1"]) bindings - applyObj env (Value $ Func Nothing env ["#1"] body) [WHNF (Value World)] + applyObj env (Value $ Func Nothing env [stringToVar "#1"] body) [WHNF (Value World)] where genLet (names, expr) expr' = ILetExpr [(PDTuplePat (map PDPatVar [stringToVar "#1", stringToVar "#2"]), IApplyExpr expr [IVarExpr "#1"])] $ @@ -405,14 +405,17 @@ evalExprShallow env (IGenerateTensorExpr fnExpr shapeExpr) = do shape <- evalExprDeep env shapeExpr >>= collectionToList ns <- mapM fromEgison shape :: EvalM Shape - xs <- mapM (indexToWHNF env . map toEgison) (enumTensorIndices ns) + xs <- mapM (evalWithIndex env . map (\n -> SingleTerm n [])) (enumTensorIndices ns) return $ newITensor ns xs where - indexToWHNF :: Env -> [EgisonValue] {- index -} -> EvalM ObjectRef - indexToWHNF (Env frame maybe_vwi) ms = do + evalWithIndex :: Env -> [ScalarData] {- index -} -> EvalM ObjectRef + evalWithIndex env@(Env frame maybe_vwi) ms = do let env' = maybe env (\(name, indices) -> Env frame $ Just (name, zipWith changeIndex indices ms)) maybe_vwi fn <- evalExprShallow env' fnExpr - newApplyObjThunkRef env fn (map (WHNF . Value) ms) + newApplyObjThunkRef env fn [WHNF (Value (Collection (Sq.fromList (map ScalarData ms))))] + changeIndex :: Index (Maybe a) -> a -> Index (Maybe a) -- Maybe we can refactor this function + changeIndex (Sup Nothing) m = Sup (Just m) + changeIndex (Sub Nothing) m = Sub (Just m) evalExprShallow env (ITensorContractExpr tExpr) = do whnf <- evalExprShallow env tExpr @@ -472,7 +475,7 @@ newApplyThunkRef env fn [x, y]) t2 >>= fromTensor _ -> applyObj env fn [WHNF whnf1, WHNF whnf2] -evalExprShallow _ expr = throwError =<< NotImplemented ("evalExprShallow for " ++ show expr) <$> getFuncNameStack +evalExprShallow _ expr = throwErrorWithTrace (NotImplemented ("evalExprShallow for " ++ show expr)) evalExprDeep :: Env -> IExpr -> EvalM EgisonValue evalExprDeep env expr = evalExprShallow env expr >>= evalWHNF @@ -492,7 +495,7 @@ return val evalMemoizedFunc - :: (IORef (HL.HashMap [Integer] WHNFData)) -> Env -> [String] -> IExpr + :: IORef (HL.HashMap [Integer] WHNFData) -> Env -> [String] -> IExpr -> [EgisonValue] -> EvalM WHNFData evalMemoizedFunc hashRef env names body args = do indices <- mapM fromEgison args @@ -500,7 +503,7 @@ case HL.lookup indices hash of Just whnf -> return whnf Nothing -> do - whnf <- applyObj env (Value (Func Nothing env names body)) (map (WHNF . Value) args) + whnf <- applyObj env (Value (Func Nothing env (map stringToVar names) body)) (map (WHNF . Value) args) liftIO $ modifyIORef hashRef (HL.insert indices whnf) return whnf @@ -563,13 +566,16 @@ applyRef env' (Value (Func mFuncName env names body)) refs = mLabelFuncName mFuncName $ if | length names == length refs -> do - evalExprShallow (extendEnv env (makeBindings' names refs)) body + frame <- makeBindings names refs + evalExprShallow (extendEnv env frame) body | length names > length refs -> do -- Currying let (bound, rest) = splitAt (length refs) names - return . Value $ Func mFuncName (extendEnv env (makeBindings' bound refs)) rest body + frame <- makeBindings bound refs + return . Value $ Func mFuncName (extendEnv env frame) rest body | otherwise -> do let (used, rest) = splitAt (length names) refs - func <- evalExprShallow (extendEnv env (makeBindings' names used)) body + frame <- makeBindings names used + func <- evalExprShallow (extendEnv env frame) body applyRef env' func rest applyRef _ (Value (CFunc env name body)) refs = do seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs) @@ -585,14 +591,14 @@ args <- mapM evalRef refs case args of [Value World] -> m - arg : _ -> throwError =<< TypeMismatch "world" arg <$> getFuncNameStack + arg : _ -> throwErrorWithTrace (TypeMismatch "world" arg) applyRef _ (Value (ScalarData fn@(SingleTerm 1 [(Symbol{}, 1)]))) refs = do args <- mapM (\ref -> evalRef ref >>= evalWHNF) refs mExprs <- mapM (\arg -> case arg of ScalarData _ -> extractScalar arg - _ -> throwError =<< EgisonBug "to use undefined functions, you have to use ScalarData args" <$> getFuncNameStack) args + _ -> throwErrorWithTrace (EgisonBug "to use undefined functions, you have to use ScalarData args")) args return (Value (ScalarData (SingleTerm 1 [(Apply fn mExprs, 1)]))) -applyRef _ whnf _ = throwError =<< TypeMismatch "function" whnf <$> getFuncNameStack +applyRef _ whnf _ = throwErrorWithTrace (TypeMismatch "function" whnf) applyObj :: Env -> WHNFData -> [Object] -> EvalM WHNFData applyObj env fn args = do @@ -609,7 +615,7 @@ IIntHash hash -> irefHash hash ICharHash hash -> irefHash hash IStrHash hash -> irefHash hash - _ -> throwError =<< TypeMismatch "hash" val <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "hash" val) where refHash' hash = do key <- fromEgison index @@ -623,20 +629,6 @@ Just ref -> evalRef ref >>= flip refHash indices Nothing -> return $ Value Undefined -updateHash :: [Integer] -> WHNFData -> WHNFData -> EvalM WHNFData -updateHash [index] tgt (IIntHash hash) = do - targetRef <- newEvaluatedObjectRef tgt - return . IIntHash $ HL.insert index targetRef hash -updateHash (index:indices) tgt (IIntHash hash) = do - val <- maybe (return $ IIntHash HL.empty) evalRef $ HL.lookup index hash - ref <- updateHash indices tgt val >>= newEvaluatedObjectRef - return . IIntHash $ HL.insert index ref hash -updateHash indices tgt (Value (IntHash hash)) = do - let keys = HL.keys hash - vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash - updateHash indices tgt (IIntHash $ HL.fromList $ zip keys vals) -updateHash _ _ v = throwError $ Default $ "expected hash value: " ++ show v - subst :: (Eq a) => a -> b -> [(a, b)] -> [(a, b)] subst k nv ((k', v'):xs) | k == k' = (k', nv):subst k nv xs | otherwise = (k', v'):subst k nv xs @@ -672,7 +664,7 @@ -- Modify |env'| for some cases let env'' = case pd of PDPatVar var -> memorizeVarInEnv env' var - _ -> env' + _ -> env' thunk <- newThunkRef env'' expr binds <- bindPrimitiveDataPattern pd thunk forM_ binds $ \(var, objref) -> do @@ -684,7 +676,7 @@ memorizeVarInEnv :: Env -> Var -> Env memorizeVarInEnv (Env frame _) (Var var is) = - Env frame (Just (var, map (fmap (const "")) is)) + Env frame (Just (var, map (fmap (\_ -> Nothing)) is)) -- -- Pattern Match @@ -704,14 +696,14 @@ } processMStatesAllDFS :: MList EvalM MatchingState -> EvalM (MList EvalM Match) -processMStatesAllDFS MNil = return MNil +processMStatesAllDFS MNil = return MNil processMStatesAllDFS (MCons (MState _ _ [] bindings []) ms) = MCons bindings . processMStatesAllDFS <$> ms -processMStatesAllDFS (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS +processMStatesAllDFS (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS processMStatesAllDFSForall :: MList EvalM MatchingState -> EvalM (MList EvalM MatchingState) -processMStatesAllDFSForall MNil = return MNil +processMStatesAllDFSForall MNil = return MNil processMStatesAllDFSForall (MCons mstate@(MState _ _ (ForallPatContext _ _ : _) _ []) ms) = MCons mstate . processMStatesAllDFSForall <$> ms -processMStatesAllDFSForall (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFSForall +processMStatesAllDFSForall (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFSForall processMStatesAll :: [MList EvalM MatchingState] -> EvalM (MList EvalM Match) processMStatesAll [] = return MNil @@ -720,7 +712,7 @@ mappend (fromList matches) $ processMStatesAll streams' processMStates :: MList EvalM MatchingState -> EvalM [MList EvalM MatchingState] -processMStates MNil = return [] +processMStates MNil = return [] processMStates (MCons state stream) = (\x y -> [x, y]) <$> processMState state <*> stream extractMatches :: [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState]) @@ -735,7 +727,7 @@ gatherBindings :: MatchingState -> Maybe [Binding] gatherBindings MState{ seqPatCtx = [], mStateBindings = b, mTrees = [] } = return b -gatherBindings _ = Nothing +gatherBindings _ = Nothing processMState :: MatchingState -> EvalM (MList EvalM MatchingState) processMState state | nullMState state = processMState' state @@ -754,11 +746,11 @@ processMStatesAllDFSForall (msingleton (MState e' l' (ForallPatContext [] []:s') b' [MAtom p2 tgt' mat']))) states b <- mAny (\case MNil -> return True - _ -> return False) statess' + _ -> return False) statess' if b then return MNil -- else return MNil - else do nstatess <- mmap (\states' -> mmap (\(MState e' l' (ForallPatContext [] []:s') b' []) -> return $ MState e' l' s' b' trees) states') statess' + else do nstatess <- mmap (mmap (\(MState e' l' (ForallPatContext [] []:s') b' []) -> return $ MState e' l' s' b' trees)) statess' mconcat nstatess _ -> processMState' state where @@ -772,7 +764,7 @@ where (f, state1, state2) = splitMState state' processMState' :: MatchingState -> EvalM (MList EvalM MatchingState) ---processMState' MState{ seqPatCtx = [], mTrees = [] } = throwError =<< EgisonBug "should not reach here (empty matching-state)" <$> getFuncNameStack +--processMState' MState{ seqPatCtx = [], mTrees = [] } = throwErrorWithTrace (EgisonBug "should not reach here (empty matching-state)") processMState' mstate@MState{ seqPatCtx = [], mTrees = [] } = return . msingleton $ mstate -- for forall pattern used in matchAll (not matchAllDFS) -- Sequential patterns and forall pattern @@ -786,7 +778,7 @@ return . msingleton $ mstate -- Matching Nodes ---processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwError =<< EgisonBug "should not reach here (empty matching-node)" <$> getFuncNameStack +--processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwErrorWithTrace (EgisonBug "should not reach here (empty matching-node)") processMState' mstate@MState{ mTrees = MNode _ MState{ seqPatCtx = [], mTrees = [] }:trees } = return . msingleton $ mstate { mTrees = trees } processMState' ms1@MState{ mTrees = MNode penv ms2@MState{ mTrees = MAtom (IVarPat name) target matcher:trees' }:trees } = @@ -795,7 +787,7 @@ case trees' of [] -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:trees } _ -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:MNode penv (ms2 { mTrees = trees' }):trees } - Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack + Nothing -> throwErrorWithTrace (UnboundVariable name) processMState' ms1@(MState _ _ _ bindings (MNode penv ms2@(MState env' loops' _ _ (MAtom (IIndexedPat (IVarPat name) indices) target matcher:trees')):trees)) = case lookup name penv of @@ -806,7 +798,7 @@ case trees' of [] -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:trees } _ -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:MNode penv (ms2 { mTrees = trees' }):trees } - Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack + Nothing -> throwErrorWithTrace (UnboundVariable name) processMState' mstate@MState{ mTrees = MNode penv state:trees } = processMState' state >>= mmap (\state' -> case state' of @@ -828,7 +820,7 @@ _ -> processMState' (mstate { mTrees = MAtom (IInductivePat name args) target matcher:trees }) - INotPat _ -> throwError =<< EgisonBug "should not reach here (not-pattern)" <$> getFuncNameStack + INotPat _ -> throwErrorWithTrace (EgisonBug "should not reach here (not-pattern)") IVarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ show pattern ILetPat bindings' pattern' -> do @@ -851,7 +843,7 @@ Value (PatternFunc env'' names expr) -> return . msingleton $ mstate { mTrees = MNode penv (MState env'' [] [] [] [MAtom expr target matcher]) : trees } where penv = zip names args - _ -> throwError =<< TypeMismatch "pattern constructor" func' <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "pattern constructor" func') IDApplyPat func args -> return . msingleton $ mstate { mTrees = MAtom (IInductivePat "apply" [func, toListPat args]) target matcher:trees } @@ -895,7 +887,7 @@ mstate { loopPatCtx = LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }] | otherwise -> fromList [mstate { loopPatCtx = LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }] - ISeqNilPat -> throwError =<< EgisonBug "should not reach here (seq nil pattern)" <$> getFuncNameStack + ISeqNilPat -> throwErrorWithTrace (EgisonBug "should not reach here (seq nil pattern)") ISeqConsPat pattern pattern' -> return . msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher] ILaterPatVar -> case seqs of @@ -934,8 +926,8 @@ IIndexedPat _ _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees } ITuplePat patterns -> do targets <- tupleToListWHNF target - when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack - when (length patterns /= length matchers) $ throwError =<< TupleLength (length patterns) (length matchers) <$> getFuncNameStack + when (length patterns /= length targets) $ throwErrorWithTrace (TupleLength (length patterns) (length targets)) + when (length patterns /= length matchers) $ throwErrorWithTrace (TupleLength (length patterns) (length matchers)) let trees' = zipWith3 MAtom patterns targets matchers ++ trees return . msingleton $ mstate { mTrees = trees' } _ -> throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern @@ -960,16 +952,16 @@ obj <- evalRef ref >>= updateHash indices target >>= newEvaluatedObjectRef return . msingleton $ mstate { mStateBindings = subst name obj bindings, mTrees = trees } Nothing -> do - obj <- updateHash indices target (IIntHash (HL.empty)) >>= newEvaluatedObjectRef + obj <- updateHash indices target (IIntHash HL.empty) >>= newEvaluatedObjectRef return . msingleton $ mstate { mStateBindings = (name,obj):bindings, mTrees = trees } IIndexedPat pattern _ -> throwError $ Default ("invalid indexed-pattern: " ++ show pattern) ITuplePat patterns -> do targets <- tupleToListWHNF target - when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack + when (length patterns /= length targets) $ throwErrorWithTrace (TupleLength (length patterns) (length targets)) let trees' = zipWith3 MAtom patterns targets (map (const Something) patterns) ++ trees return . msingleton $ mstate { mTrees = trees' } _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ show pattern - _ -> throwError =<< EgisonBug ("should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern) <$> getFuncNameStack + _ -> throwErrorWithTrace (EgisonBug ("should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern)) inductiveMatch :: Env -> IPattern -> WHNFData -> Matcher -> EvalM ([IPattern], MList EvalM ObjectRef, [Matcher]) @@ -997,7 +989,7 @@ evalExprShallow env expr >>= collectionToRefs _ -> cont failPPPatternMatch = throwError (Default "failed primitive pattern pattern match") - failPDPatternMatch = throwError =<< PrimitiveMatchFailure <$> getFuncNameStack + failPDPatternMatch = throwErrorWithTrace PrimitiveMatchFailure primitivePatPatternMatch :: Env -> PrimitivePatPattern -> IPattern -> MatchM ([IPattern], [Binding]) @@ -1020,7 +1012,7 @@ bindPrimitiveDataPattern pdp ref = do r <- runMaybeT $ primitiveDataPatternMatch pdp ref case r of - Nothing -> throwError =<< PrimitiveMatchFailure <$> getFuncNameStack + Nothing -> throwErrorWithTrace PrimitiveMatchFailure Just binding -> return binding primitiveDataPatternMatch :: IPrimitiveDataPattern -> ObjectRef -> MatchM [Binding] @@ -1062,7 +1054,7 @@ whnf <- lift $ evalRef ref case whnf of Value val | val == evalConstant expr -> return [] - _ -> matchFail + _ -> matchFail extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopPatContext] -> Env extendEnvForNonLinearPatterns env bindings loops = extendEnv env $ bindings ++ map (\(LoopPatContext (name, ref) _ _ _ _) -> (stringToVar name, ref)) loops @@ -1075,7 +1067,7 @@ whnfs <- mapM evalRef refs ms <- mapM evalMatcherWHNF whnfs return $ Tuple ms -evalMatcherWHNF whnf = throwError =<< TypeMismatch "matcher" whnf <$> getFuncNameStack +evalMatcherWHNF whnf = throwErrorWithTrace (TypeMismatch "matcher" whnf) -- -- Util @@ -1098,3 +1090,20 @@ tref js' (Tensor ns xs js') >>= tContract' >>= fromTensor where js' = if override then js else is ++ js + +makeBindings :: [Var] -> [ObjectRef] -> EvalM [Binding] +makeBindings vs refs = zipWithM makeBinding vs refs >>= return . concat + where + makeBinding :: Var -> ObjectRef -> EvalM [Binding] + makeBinding v@(Var _ []) ref = return [(v, ref)] + makeBinding v@(Var name is) ref = do + val <- evalRefDeep ref + case val of + TensorData (Tensor _ _ js) -> do + frame <- pmIndices is js + return ((v, ref) : frame) + _ -> throwErrorWithTrace (TypeMismatch "tensor" (Value val)) + +makeBindings' :: [String] -> [ObjectRef] -> [Binding] +makeBindings' xs = zip (map stringToVar xs) + diff --git a/hs-src/Language/Egison/Data.hs b/hs-src/Language/Egison/Data.hs --- a/hs-src/Language/Egison/Data.hs +++ b/hs-src/Language/Egison/Data.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE QuasiQuotes #-} {- | Module : Language.Egison.Data @@ -42,6 +41,7 @@ , refVar -- * Errors , EgisonError (..) + , throwErrorWithTrace -- * Monads , EvalM , fromEvalM @@ -50,20 +50,20 @@ import Control.Exception -import Control.Monad.Except hiding (join) +import Control.Monad.Except hiding (join) import Control.Monad.Trans.State.Strict -import Data.Foldable (toList) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap +import Data.Foldable (toList) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.IORef -import Data.Sequence (Seq) -import qualified Data.Sequence as Sq -import qualified Data.Vector as V +import Data.Sequence (Seq) +import qualified Data.Sequence as Sq +import qualified Data.Vector as V -import Data.List (intercalate) -import Data.Text (Text) -import Text.Show.Unicode (ushow) +import Data.List (intercalate) +import Data.Text (Text) +import Text.Show.Unicode (ushow) import Data.Ratio import System.IO @@ -93,7 +93,7 @@ | CharHash (HashMap Char EgisonValue) | StrHash (HashMap Text EgisonValue) | UserMatcher Env [IPatternDef] - | Func (Maybe String) Env [String] IExpr + | Func (Maybe Var) Env [Var] IExpr | CFunc Env String IExpr | MemoizedFunc (IORef (HashMap [Integer] WHNFData)) Env [String] IExpr | PatternFunc Env [String] IPattern @@ -157,15 +157,13 @@ f js = Collection (Sq.fromList (map scalarIndexToEgison js)) symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [ScalarData fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n] symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n] -symbolExprToEgison (FunctionData name argnames args js, n) = - Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData argnames)), Collection (Sq.fromList (map ScalarData args)), f js], toEgison n] - where - f js = Collection (Sq.fromList (map scalarIndexToEgison js)) +symbolExprToEgison (FunctionData name argnames args, n) = + Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData argnames)), Collection (Sq.fromList (map ScalarData args))], toEgison n] scalarIndexToEgison :: Index ScalarData -> EgisonValue -scalarIndexToEgison (Sup k) = InductiveData "Sup" [ScalarData k] -scalarIndexToEgison (Sub k) = InductiveData "Sub" [ScalarData k] -scalarIndexToEgison (User k) = InductiveData "User" [ScalarData k] +scalarIndexToEgison (Sup k) = InductiveData "Sup" [ScalarData k] +scalarIndexToEgison (Sub k) = InductiveData "Sub" [ScalarData k] +scalarIndexToEgison (User k) = InductiveData "User" [ScalarData k] -- Implementation of 'toMathExpr' (Primitive function) egisonToScalarData :: EgisonValue -> EvalM ScalarData @@ -186,15 +184,15 @@ egisonToScalarData s1@(InductiveData "Function" _) = do s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)]) return $ SingleTerm 1 [s1'] -egisonToScalarData val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack +egisonToScalarData val = throwErrorWithTrace (TypeMismatch "math expression" (Value val)) egisonToPolyExpr :: EgisonValue -> EvalM PolyExpr egisonToPolyExpr (InductiveData "Plus" [Collection ts]) = Plus <$> mapM egisonToTermExpr (toList ts) -egisonToPolyExpr val = throwError =<< TypeMismatch "math poly expression" (Value val) <$> getFuncNameStack +egisonToPolyExpr val = throwErrorWithTrace (TypeMismatch "math poly expression" (Value val)) egisonToTermExpr :: EgisonValue -> EvalM TermExpr egisonToTermExpr (InductiveData "Term" [n, Collection ts]) = Term <$> fromEgison n <*> mapM egisonToSymbolExpr (toList ts) -egisonToTermExpr val = throwError =<< TypeMismatch "math term expression" (Value val) <$> getFuncNameStack +egisonToTermExpr val = throwErrorWithTrace (TypeMismatch "math term expression" (Value val)) egisonToSymbolExpr :: EgisonValue -> EvalM (SymbolExpr, Integer) egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, Collection seq], n]) = do @@ -213,22 +211,20 @@ mExpr' <- egisonToScalarData mExpr n' <- fromEgison n return (Quote mExpr', n') -egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection argnames, Collection args, Collection seq], n]) = do +egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection argnames, Collection args], n]) = do name' <- extractScalar name argnames' <- mapM extractScalar (toList argnames) args' <- mapM extractScalar (toList args) - let js = toList seq - js' <- mapM egisonToScalarIndex js n' <- fromEgison n - return (FunctionData name' argnames' args' js', n') -egisonToSymbolExpr val = throwError =<< TypeMismatch "math symbol expression" (Value val) <$> getFuncNameStack + return (FunctionData name' argnames' args', n') +egisonToSymbolExpr val = throwErrorWithTrace (TypeMismatch "math symbol expression" (Value val)) egisonToScalarIndex :: EgisonValue -> EvalM (Index ScalarData) egisonToScalarIndex j = case j of InductiveData "Sup" [ScalarData k] -> return (Sup k) InductiveData "Sub" [ScalarData k] -> return (Sub k) InductiveData "User" [ScalarData k] -> return (User k) - _ -> throwError =<< TypeMismatch "math symbol expression" (Value j) <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "math symbol expression" (Value j)) -- -- ExtractScalar @@ -236,7 +232,7 @@ extractScalar :: EgisonValue -> EvalM ScalarData extractScalar (ScalarData mExpr) = return mExpr -extractScalar val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack +extractScalar val = throwErrorWithTrace (TypeMismatch "math expression" (Value val)) -- New-syntax version of EgisonValue pretty printer. -- TODO(momohatt): Don't make it a show instance of EgisonValue. @@ -281,25 +277,25 @@ isAtomic :: EgisonValue -> Bool isAtomic (InductiveData _ []) = True isAtomic (InductiveData _ _) = False -isAtomic (ScalarData m) = isAtom m -isAtomic _ = True +isAtomic (ScalarData m) = isAtom m +isAtomic _ = True instance Eq EgisonValue where - (Char c) == (Char c') = c == c' - (String str) == (String str') = str == str' - (Bool b) == (Bool b') = b == b' - (ScalarData x) == (ScalarData y) = x == y + (Char c) == (Char c') = c == c' + (String str) == (String str') = str == str' + (Bool b) == (Bool b') = b == b' + (ScalarData x) == (ScalarData y) = x == y (TensorData (Tensor js xs _)) == (TensorData (Tensor js' xs' _)) = js == js' && xs == xs' - (Float x) == (Float x') = x == x' - (InductiveData name vals) == (InductiveData name' vals') = name == name' && vals == vals' - (Tuple vals) == (Tuple vals') = vals == vals' - (Collection vals) == (Collection vals') = vals == vals' - (IntHash vals) == (IntHash vals') = vals == vals' - (CharHash vals) == (CharHash vals') = vals == vals' - (StrHash vals) == (StrHash vals') = vals == vals' + (Float x) == (Float x') = x == x' + (InductiveData name vals) == (InductiveData name' vals') = name == name' && vals == vals' + (Tuple vals) == (Tuple vals') = vals == vals' + (Collection vals) == (Collection vals') = vals == vals' + (IntHash vals) == (IntHash vals') = vals == vals' + (CharHash vals) == (CharHash vals') = vals == vals' + (StrHash vals) == (StrHash vals') = vals == vals' -- Temporary: searching a better solution - (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _) = name1 == name2 - _ == _ = False + (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _) = name1 == name2 + _ == _ = False -- -- Egison data and Haskell data @@ -311,55 +307,55 @@ instance EgisonData Char where toEgison = Char fromEgison (Char c) = return c - fromEgison val = throwError =<< TypeMismatch "char" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "char" (Value val)) instance EgisonData Text where toEgison = String fromEgison (String str) = return str - fromEgison val = throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "string" (Value val)) instance EgisonData Bool where toEgison = Bool fromEgison (Bool b) = return b - fromEgison val = throwError =<< TypeMismatch "bool" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "bool" (Value val)) instance EgisonData Integer where toEgison 0 = ScalarData (Div (Plus []) (Plus [Term 1 []])) toEgison i = ScalarData (SingleTerm i []) fromEgison (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = return 0 - fromEgison (ScalarData (SingleTerm x [])) = return x - fromEgison val = throwError =<< TypeMismatch "integer" (Value val) <$> getFuncNameStack + fromEgison (ScalarData (SingleTerm x [])) = return x + fromEgison val = throwErrorWithTrace (TypeMismatch "integer" (Value val)) instance EgisonData Rational where toEgison r = ScalarData $ mathNormalize' (Div (Plus [Term (numerator r) []]) (Plus [Term (denominator r) []])) - fromEgison (ScalarData (Div (Plus []) _)) = return 0 + fromEgison (ScalarData (Div (Plus []) _)) = return 0 fromEgison (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return (x % y) - fromEgison val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "rational" (Value val)) instance EgisonData Double where toEgison f = Float f fromEgison (Float f) = return f - fromEgison val = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "float" (Value val)) instance EgisonData Handle where toEgison = Port fromEgison (Port h) = return h - fromEgison val = throwError =<< TypeMismatch "port" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "port" (Value val)) instance EgisonData a => EgisonData [a] where toEgison xs = Collection $ Sq.fromList (map toEgison xs) fromEgison (Collection seq) = mapM fromEgison (toList seq) - fromEgison val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "collection" (Value val)) instance EgisonData () where toEgison () = Tuple [] fromEgison (Tuple []) = return () - fromEgison val = throwError =<< TypeMismatch "zero element tuple" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "zero element tuple" (Value val)) instance (EgisonData a, EgisonData b) => EgisonData (a, b) where toEgison (x, y) = Tuple [toEgison x, toEgison y] fromEgison (Tuple [x, y]) = liftM2 (,) (fromEgison x) (fromEgison y) - fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "two elements tuple" (Value val)) instance (EgisonData a, EgisonData b, EgisonData c) => EgisonData (a, b, c) where toEgison (x, y, z) = Tuple [toEgison x, toEgison y, toEgison z] @@ -368,7 +364,7 @@ y' <- fromEgison y z' <- fromEgison z return (x', y', z') - fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "two elements tuple" (Value val)) instance (EgisonData a, EgisonData b, EgisonData c, EgisonData d) => EgisonData (a, b, c, d) where toEgison (x, y, z, w) = Tuple [toEgison x, toEgison y, toEgison z, toEgison w] @@ -378,12 +374,12 @@ z' <- fromEgison z w' <- fromEgison w return (x', y', z', w') - fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "two elements tuple" (Value val)) instance EgisonData (IORef EgisonValue) where toEgison = RefBox fromEgison (RefBox ref) = return ref - fromEgison val = throwError =<< TypeMismatch "ioRef" (Value val) <$> getFuncNameStack + fromEgison val = throwErrorWithTrace (TypeMismatch "ioRef" (Value val)) -- -- Internal Data @@ -411,15 +407,15 @@ | ISubCollection ObjectRef instance Show WHNFData where - show (Value val) = show val - show (IInductiveData name _) = "<" ++ name ++ " ...>" - show (ITuple _) = "(...)" - show (ICollection _) = "[...]" - show (IIntHash _) = "{|...|}" - show (ICharHash _) = "{|...|}" - show (IStrHash _) = "{|...|}" + show (Value val) = show val + show (IInductiveData name _) = "<" ++ name ++ " ...>" + show (ITuple _) = "(...)" + show (ICollection _) = "[...]" + show (IIntHash _) = "{|...|}" + show (ICharHash _) = "{|...|}" + show (IStrHash _) = "{|...|}" show (ITensor (Tensor ns xs _)) = "[|" ++ show (length ns) ++ show (V.length xs) ++ "|]" - show (ITensor (Scalar _)) = "scalar" + show (ITensor (Scalar _)) = "scalar" instance Show Object where show (Thunk _) = "#" @@ -432,21 +428,21 @@ -- Environment -- -data Env = Env [HashMap Var ObjectRef] (Maybe (String, [Index String])) +data Env = Env [HashMap Var ObjectRef] (Maybe (String, [Index (Maybe ScalarData)])) type Binding = (Var, ObjectRef) instance {-# OVERLAPPING #-} Show (Index EgisonValue) where show (Sup i) = case i of ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "~[" ++ show i ++ "]" - _ -> "~" ++ show i + _ -> "~" ++ show i show (Sub i) = case i of ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]" - _ -> "_" ++ show i + _ -> "_" ++ show i show (SupSub i) = "~_" ++ show i show (User i) = case i of ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]" - _ -> "|" ++ show i + _ -> "|" ++ show i show (DF i j) = "_d" ++ show i ++ show j nullEnv :: Env @@ -466,7 +462,7 @@ -- Errors -- -type CallStack = [String] +type CallStack = [Var] data EgisonError = UnboundVariable String CallStack @@ -505,7 +501,7 @@ show (Default message) = "Error: " ++ message showTrace :: CallStack -> String -showTrace stack = "\n stack trace: " ++ intercalate ", " stack +showTrace stack = "\n stack trace: " ++ intercalate ", " (map show stack) instance Exception EgisonError @@ -517,8 +513,8 @@ type EvalM = EvalT RuntimeM -instance {-# OVERLAPPING #-} MonadFail EvalM where - fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack +throwErrorWithTrace :: (CallStack -> EgisonError) -> EvalM a +throwErrorWithTrace e = throwError . e =<< getFuncNameStack instance MonadRuntime EvalM where fresh = lift $ lift fresh diff --git a/hs-src/Language/Egison/Data/Collection.hs b/hs-src/Language/Egison/Data/Collection.hs --- a/hs-src/Language/Egison/Data/Collection.hs +++ b/hs-src/Language/Egison/Data/Collection.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} {- | Module : Language.Egison.Data.Collection @@ -18,26 +18,25 @@ , makeICollection ) where -import Control.Monad.Except (throwError, lift, liftIO) -import Control.Monad.Trans.Maybe (runMaybeT) +import Control.Monad.Except (lift, liftIO) +import Control.Monad.Trans.Maybe (runMaybeT) -import Data.Foldable (toList) +import Data.Foldable (toList) import Data.IORef -import Data.Maybe (fromJust) -import Data.Sequence (Seq, ViewL (..), ViewR (..), (><)) -import qualified Data.Sequence as Sq +import Data.Maybe (fromJust) +import Data.Sequence (Seq, ViewL (..), ViewR (..), (><)) +import qualified Data.Sequence as Sq import Language.Egison.Data import Language.Egison.Data.Utils -import Language.Egison.EvalState (MonadEval(..)) -import Language.Egison.Match import Language.Egison.MList +import Language.Egison.Match expandCollection :: WHNFData -> EvalM (Seq Inner) expandCollection (Value (Collection vals)) = mapM (fmap IElement . newEvaluatedObjectRef . Value) vals expandCollection (ICollection innersRef) = liftIO $ readIORef innersRef -expandCollection val = throwError =<< TypeMismatch "collection" val <$> getFuncNameStack +expandCollection val = throwErrorWithTrace (TypeMismatch "collection" val) isEmptyCollection :: WHNFData -> EvalM Bool isEmptyCollection (Value (Collection col)) = return $ Sq.null col @@ -104,11 +103,11 @@ (head, tail) <- fromJust <$> runMaybeT (unconsCollection whnf) tail' <- evalRef tail return $ MCons head (collectionToRefs tail') -collectionToRefs whnf = throwError =<< TypeMismatch "collection" whnf <$> getFuncNameStack +collectionToRefs whnf = throwErrorWithTrace (TypeMismatch "collection" whnf) collectionToList :: EgisonValue -> EvalM [EgisonValue] collectionToList (Collection sq) = return $ toList sq -collectionToList val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack +collectionToList val = throwErrorWithTrace (TypeMismatch "collection" (Value val)) makeICollection :: [WHNFData] -> EvalM WHNFData makeICollection xs = do diff --git a/hs-src/Language/Egison/Data/Utils.hs b/hs-src/Language/Egison/Data/Utils.hs --- a/hs-src/Language/Egison/Data/Utils.hs +++ b/hs-src/Language/Egison/Data/Utils.hs @@ -10,21 +10,24 @@ , evalObj , writeObjectRef , newEvaluatedObjectRef - , makeBindings - , makeBindings' , tupleToRefs , tupleToListWHNF , tupleToList , makeTuple , makeITuple + , pmIndices + , updateHash ) where +import Control.Monad import Control.Monad.State (liftIO) +import Control.Monad.Except (throwError) import Data.IORef +import qualified Data.HashMap.Lazy as HL import Language.Egison.Data -import Language.Egison.IExpr (Var, stringToVar) +import Language.Egison.IExpr evalRef :: ObjectRef -> EvalM WHNFData @@ -38,7 +41,7 @@ return val evalObj :: Object -> EvalM WHNFData -evalObj (WHNF val) = return val +evalObj (WHNF val) = return val evalObj (Thunk thunk) = thunk writeObjectRef :: ObjectRef -> WHNFData -> EvalM () @@ -47,16 +50,10 @@ newEvaluatedObjectRef :: WHNFData -> EvalM ObjectRef newEvaluatedObjectRef = liftIO . newIORef . WHNF -makeBindings :: [Var] -> [ObjectRef] -> [Binding] -makeBindings = zip - -makeBindings' :: [String] -> [ObjectRef] -> [Binding] -makeBindings' xs = zip (map stringToVar xs) - tupleToRefs :: WHNFData -> EvalM [ObjectRef] -tupleToRefs (ITuple refs) = return refs +tupleToRefs (ITuple refs) = return refs tupleToRefs (Value (Tuple vals)) = mapM (newEvaluatedObjectRef . Value) vals -tupleToRefs whnf = return <$> newEvaluatedObjectRef whnf +tupleToRefs whnf = return <$> newEvaluatedObjectRef whnf tupleToListWHNF :: WHNFData -> EvalM [WHNFData] tupleToListWHNF (ITuple refs) = mapM evalRef refs @@ -76,3 +73,59 @@ makeITuple [] = return (ITuple []) makeITuple [x] = return x makeITuple xs = ITuple <$> mapM newEvaluatedObjectRef xs + +pmIndices :: [Index (Maybe Var)] -> [Index EgisonValue] -> EvalM [Binding] +pmIndices [] [] = return [] +pmIndices (MultiSub (Just a) s (Just e):xs) vs = do + let (vs1, vs2) = span isSub vs + let l = fromIntegral (length vs1) + eRef <- newEvaluatedObjectRef (Value (toEgison l)) + let hash = (IIntHash HL.empty) + hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash (zip [s..(s + l - 1)] (map (\(Sub v) -> Value v) vs1)) + aRef <- newEvaluatedObjectRef hash + bs <- pmIndices xs vs2 + return ((a, aRef) : (e, eRef) : bs) + where + isSub (Sub _) = True + isSub _ = False +pmIndices (MultiSup (Just a) s (Just e):xs) vs = do + let (vs1, vs2) = span isSup vs + let l = fromIntegral (length vs1) + eRef <- newEvaluatedObjectRef (Value (toEgison l)) + let hash = (IIntHash HL.empty) + hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash (zip [s..(s + l - 1)] (map (\(Sup v) -> Value v) vs1)) + aRef <- newEvaluatedObjectRef hash + bs <- pmIndices xs vs2 + return ((a, aRef) : (e, eRef) : bs) + where + isSup (Sup _) = True + isSup _ = False + +pmIndices (x:xs) (v:vs) = do + bs <- pmIndex x v + bs' <- pmIndices xs vs + return (bs ++ bs') +pmIndices _ _ = throwErrorWithTrace InconsistentTensorIndex + +pmIndex :: Index (Maybe Var) -> Index EgisonValue -> EvalM [Binding] +pmIndex (Sub (Just var)) (Sub val) = do + ref <- newEvaluatedObjectRef (Value val) + return [(var, ref)] +pmIndex (Sup (Just var)) (Sup val) = do + ref <- newEvaluatedObjectRef (Value val) + return [(var, ref)] +pmIndex _ _ = throwErrorWithTrace InconsistentTensorIndex + +updateHash :: [Integer] -> WHNFData -> WHNFData -> EvalM WHNFData +updateHash [index] tgt (IIntHash hash) = do + targetRef <- newEvaluatedObjectRef tgt + return . IIntHash $ HL.insert index targetRef hash +updateHash (index:indices) tgt (IIntHash hash) = do + val <- maybe (return $ IIntHash HL.empty) evalRef $ HL.lookup index hash + ref <- updateHash indices tgt val >>= newEvaluatedObjectRef + return . IIntHash $ HL.insert index ref hash +updateHash indices tgt (Value (IntHash hash)) = do + let keys = HL.keys hash + vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash + updateHash indices tgt (IIntHash $ HL.fromList $ zip keys vals) +updateHash _ _ v = throwError $ Default $ "expected hash value: " ++ show v 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 @@ -13,10 +13,10 @@ , desugarExpr ) where -import Control.Monad.Except (throwError) -import Data.Char (toUpper) -import Data.Foldable (foldrM) -import Data.List (union) +import Control.Monad.Except (throwError) +import Data.Char (toUpper) +import Data.Foldable (foldrM) +import Data.List (union) import Language.Egison.AST import Language.Egison.Data @@ -25,11 +25,6 @@ desugarTopExpr :: TopExpr -> EvalM (Maybe ITopExpr) -desugarTopExpr (Define (VarWithIndices name []) expr) = do - expr' <- desugar expr - case expr' of - ILambdaExpr Nothing args body -> return . Just $ IDefine (Var name []) (ILambdaExpr (Just name) args body) - _ -> return . Just $ IDefine (Var name []) expr' desugarTopExpr (Define vwi expr) = do (var, iexpr) <- desugarDefineWithIndices vwi expr return . Just $ IDefine var iexpr @@ -127,39 +122,51 @@ desugar (MatchAllLambdaExpr matcher clauses) = do name <- fresh - ILambdaExpr Nothing [name] <$> + ILambdaExpr Nothing [stringToVar name] <$> desugar (MatchAllExpr BFSMode (VarExpr name) matcher clauses) desugar (MatchLambdaExpr matcher clauses) = do name <- fresh - ILambdaExpr Nothing [name] <$> + ILambdaExpr Nothing [stringToVar name] <$> desugar (MatchExpr BFSMode (VarExpr name) matcher clauses) --- TODO: Allow nested MultiSubscript and MultiSuperscript -desugar (IndexedExpr b expr indices) = - case indices of - [MultiSubscript x y] -> - case (x, y) of - (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) -> - desugarMultiScript ISubrefsExpr b1 e1 n1 n2 - _ -> throwError $ Default "Index should be IndexedExpr for multi subscript" - [MultiSuperscript x y] -> - case (x, y) of - (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) -> - desugarMultiScript ISuprefsExpr b1 e1 n1 n2 - _ -> throwError $ Default "Index should be IndexedExpr for multi superscript" - _ -> IIndexedExpr b <$> desugar expr <*> mapM desugarIndex indices +desugar (IndexedExpr b expr indices) = do + expr' <- desugar expr + desugarIndexedExpr b expr' indices where - desugarMultiScript refExpr b1 e1 n1 n2 = do + desugarIndexedExpr :: Bool -> IExpr -> [IndexExpr Expr] -> EvalM IExpr + desugarIndexedExpr b expr' indices = + case indices of + [] -> return expr' + (MultiSubscript x y:indices') -> + case (x, y) of + (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) -> do + expr'' <- desugarMultiScript b expr' ISubrefsExpr b1 e1 n1 n2 + desugarIndexedExpr False expr'' indices' + _ -> throwError $ Default "Index should be IndexedExpr for multi subscript" + (MultiSuperscript x y:indices') -> + case (x, y) of + (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) -> do + expr'' <- desugarMultiScript b expr' ISuprefsExpr b1 e1 n1 n2 + desugarIndexedExpr False expr'' indices' + _ -> throwError $ Default "Index should be IndexedExpr for multi superscript" + _ -> do + let (is, indices') = break isMulti indices + expr'' <- IIndexedExpr b expr' <$> mapM desugarIndex is + desugarIndexedExpr False expr'' indices' + desugarMultiScript b expr' refExpr b1 e1 n1 n2 = do k <- fresh n1' <- desugar (extractIndexExpr n1) n2' <- desugar (extractIndexExpr n2) e1' <- desugar e1 - expr' <- desugar expr return $ refExpr b expr' (makeIApply "map" - [ILambdaExpr Nothing [k] (IIndexedExpr b1 e1' [Sub (IVarExpr k)]), + [ILambdaExpr Nothing [stringToVar k] (IIndexedExpr b1 e1' [Sub (IVarExpr k)]), makeIApply "between" [n1', n2']]) + isMulti (MultiSubscript _ _) = True + isMulti (MultiSuperscript _ _) = True + isMulti _ = False + desugar (SubrefsExpr bool expr1 expr2) = ISubrefsExpr bool <$> desugar expr1 <*> desugar expr2 @@ -190,7 +197,7 @@ (args', expr') <- foldrM desugarArg ([], expr) args desugar $ LambdaExpr' args' expr' where - desugarArg :: Arg ArgPattern -> ([Arg String], Expr) -> EvalM ([Arg String], Expr) + desugarArg :: Arg ArgPattern -> ([Arg VarWithIndices], Expr) -> EvalM ([Arg VarWithIndices], Expr) desugarArg (TensorArg x) (args, expr) = do (var, expr') <- desugarArgPat x expr return (TensorArg var : args, expr') @@ -204,50 +211,58 @@ -- Desugar argument patterns. Examples: -- \$(%x, %y) -> expr ==> \$tmp -> let (tmp1, tmp2) := tmp in (\%x %y -> expr) tmp1 tmp2 -- \(x, (y, z)) -> expr ==> \tmp -> let (tmp1, tmp2) := tmp in (\x (y, z) -> expr) tmp1 tmp2 - desugarArgPat :: ArgPattern -> Expr -> EvalM (String, Expr) + -- \%($x :: xs) -> expr ==> \%tmp -> let (tmp1 :: xs) := tmp in (\$x %xs -> expr) tmp1 tmp2 + desugarArgPat :: ArgPattern -> Expr -> EvalM (VarWithIndices, Expr) desugarArgPat APWildCard expr = do tmp <- fresh - return (tmp, LetExpr [Bind PDWildCard (VarExpr tmp)] expr) + let tmp' = stringToVarWithIndices tmp + return (tmp', LetExpr [Bind PDWildCard (VarExpr tmp)] expr) desugarArgPat (APPatVar var) expr = return (var, expr) desugarArgPat (APTuplePat args) expr = do tmp <- fresh + let tmp' = stringToVarWithIndices tmp tmps <- mapM (const fresh) args - return (tmp, LetExpr [Bind (PDTuplePat (map PDPatVar tmps)) (VarExpr tmp)] - (ApplyExpr (LambdaExpr args expr) (map VarExpr tmps))) + return (tmp', LetExpr [Bind (PDTuplePat (map PDPatVar tmps)) (VarExpr tmp)] + (ApplyExpr (LambdaExpr args expr) (map VarExpr tmps))) desugarArgPat (APInductivePat ctor args) expr = do tmp <- fresh + let tmp' = stringToVarWithIndices tmp tmps <- mapM (const fresh) args - return (tmp, LetExpr [Bind (PDInductivePat ctor (map PDPatVar tmps)) (VarExpr tmp)] - (ApplyExpr (LambdaExpr args expr) (map VarExpr tmps))) + return (tmp', LetExpr [Bind (PDInductivePat ctor (map PDPatVar tmps)) (VarExpr tmp)] + (ApplyExpr (LambdaExpr args expr) (map VarExpr tmps))) desugarArgPat APEmptyPat expr = do tmp <- fresh - return (tmp, LetExpr [Bind PDEmptyPat (VarExpr tmp)] expr) + let tmp' = stringToVarWithIndices tmp + return (tmp', LetExpr [Bind PDEmptyPat (VarExpr tmp)] expr) desugarArgPat (APConsPat arg1 arg2) expr = do tmp <- fresh + let tmp' = stringToVarWithIndices tmp tmp1 <- fresh tmp2 <- fresh - return (tmp, LetExpr [Bind (PDConsPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)] - (ApplyExpr (LambdaExpr [arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2])) + return (tmp', LetExpr [Bind (PDConsPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)] + (ApplyExpr (LambdaExpr [arg1, TensorArg arg2] expr) [VarExpr tmp1, VarExpr tmp2])) desugarArgPat (APSnocPat arg1 arg2) expr = do tmp <- fresh + let tmp' = stringToVarWithIndices tmp tmp1 <- fresh tmp2 <- fresh - return (tmp, LetExpr [Bind (PDSnocPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)] - (ApplyExpr (LambdaExpr [arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2])) + return (tmp', LetExpr [Bind (PDSnocPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)] + (ApplyExpr (LambdaExpr [TensorArg arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2])) -desugar (LambdaExpr' names expr) = do - let (args', expr') = foldr desugarInvertedArgs ([], expr) names +desugar (LambdaExpr' vwis expr) = do + let (vwis', expr') = foldr desugarInvertedArgs ([], expr) vwis + let args' = map varWithIndicesToVar vwis' expr' <- desugar expr' return $ ILambdaExpr Nothing args' expr' where - desugarInvertedArgs :: Arg String -> ([String], Expr) -> ([String], Expr) + desugarInvertedArgs :: Arg VarWithIndices -> ([VarWithIndices], Expr) -> ([VarWithIndices], Expr) desugarInvertedArgs (TensorArg x) (args, expr) = (x : args, expr) desugarInvertedArgs (ScalarArg x) (args, expr) = (x : args, - TensorMapExpr (LambdaExpr' [TensorArg x] expr) (VarExpr x)) + TensorMapExpr (LambdaExpr' [TensorArg x] expr) (VarExpr (extractNameFromVarWithIndices x))) desugarInvertedArgs (InvertedScalarArg x) (args, expr) = (x : args, - TensorMapExpr (LambdaExpr' [TensorArg x] expr) (FlipIndicesExpr (VarExpr x))) + TensorMapExpr (LambdaExpr' [TensorArg x] expr) (FlipIndicesExpr (VarExpr (extractNameFromVarWithIndices x)))) desugar (MemoizedLambdaExpr names expr) = IMemoizedLambdaExpr names <$> desugar expr @@ -308,15 +323,15 @@ desugar (SectionExpr op Nothing Nothing) = do x <- fresh y <- fresh - ILambdaExpr Nothing [x, y] <$> desugar (InfixExpr op (VarExpr x) (VarExpr y)) + ILambdaExpr Nothing [stringToVar x, stringToVar y] <$> desugar (InfixExpr op (VarExpr x) (VarExpr y)) desugar (SectionExpr op Nothing (Just expr2)) = do x <- fresh - ILambdaExpr Nothing [x] <$> desugar (InfixExpr op (VarExpr x) expr2) + ILambdaExpr Nothing [stringToVar x] <$> desugar (InfixExpr op (VarExpr x) expr2) desugar (SectionExpr op (Just expr1) Nothing) = do y <- fresh - ILambdaExpr Nothing [y] <$> desugar (InfixExpr op expr1 (VarExpr y)) + ILambdaExpr Nothing [stringToVar y] <$> desugar (InfixExpr op expr1 (VarExpr y)) desugar SectionExpr{} = throwError $ Default "Cannot reach here: section with both arguments" @@ -362,10 +377,25 @@ desugar (AnonParamExpr n) = return $ IVarExpr ('%' : show n) desugar (AnonParamFuncExpr n expr) = do - expr' <- desugar expr - let lambda = ILambdaExpr Nothing (map (\n -> '%' : show n) [1..n]) expr' + let args = map (\n -> stringToVarWithIndices ('%' : show n)) [1..n] + lambda <- desugar $ LambdaExpr' (map TensorArg args) expr return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0") +desugar (AnonTupleParamFuncExpr 1 expr) = do + lambda <- desugar $ LambdaExpr' [TensorArg (stringToVarWithIndices "%1")] expr + return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0") +desugar (AnonTupleParamFuncExpr n expr) = do + let args = map (\n -> stringToVarWithIndices ('%' : show n)) [1..n] + lambda <- desugar $ + LambdaExpr [TensorArg (APTuplePat $ map (TensorArg . APPatVar) args)] expr + return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0") + +desugar (AnonListParamFuncExpr n expr) = do + let args' = map (\n -> TensorArg (APPatVar (stringToVarWithIndices ('%' : show n)))) [1..n] + let args = foldr APConsPat APEmptyPat args' + lambda <- desugar $ LambdaExpr [TensorArg args] expr + return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0") + desugar (QuoteExpr expr) = IQuoteExpr <$> desugar expr @@ -394,20 +424,20 @@ collectNames pats = foldl union [] (map collectName pats) collectName :: Pattern -> [String] - collectName (ForallPat pat1 pat2) = collectName pat1 `union` collectName pat2 - collectName (InfixPat _ pat1 pat2) = collectName pat1 `union` collectName pat2 - collectName (NotPat pat) = collectName pat - collectName (AndPat pat1 pat2) = collectName pat1 `union` collectName pat2 - collectName (OrPat pat1 pat2) = collectName pat1 `union` collectName pat2 - collectName (TuplePat pats) = collectNames pats - collectName (InductiveOrPApplyPat _ pats) = collectNames pats - collectName (InductivePat _ pats) = collectNames pats - collectName (PApplyPat _ pats) = collectNames pats - collectName (DApplyPat _ pats) = collectNames pats + collectName (ForallPat pat1 pat2) = collectName pat1 `union` collectName pat2 + collectName (InfixPat _ pat1 pat2) = collectName pat1 `union` collectName pat2 + collectName (NotPat pat) = collectName pat + collectName (AndPat pat1 pat2) = collectName pat1 `union` collectName pat2 + collectName (OrPat pat1 pat2) = collectName pat1 `union` collectName pat2 + collectName (TuplePat pats) = collectNames pats + collectName (InductiveOrPApplyPat _ pats) = collectNames pats + collectName (InductivePat _ pats) = collectNames pats + collectName (PApplyPat _ pats) = collectNames pats + collectName (DApplyPat _ pats) = collectNames pats collectName (LoopPat _ (LoopRange _ _ endNumPat) pat1 pat2) = collectName endNumPat `union` collectName pat1 `union` collectName pat2 - collectName (LetPat _ pat) = collectName pat - collectName (IndexedPat (PatVar var) _) = [var] - collectName _ = [] + collectName (LetPat _ pat) = collectName pat + collectName (IndexedPat (PatVar var) _) = [var] + collectName _ = [] makeBinding :: String -> IBindingExpr makeBinding var = (PDPatVar (stringToVar var), IHashExpr []) @@ -453,7 +483,7 @@ expr' <- desugar expr case (name, expr') of (PDPatVar var, ILambdaExpr Nothing args body) -> - return (name', ILambdaExpr (Just var) args body) + return (name', ILambdaExpr (Just (Var var [])) args body) _ -> return (name', expr') desugarBinding (BindWithIndices vwi expr) = do (var, iexpr) <- desugarDefineWithIndices vwi expr @@ -470,6 +500,12 @@ desugarPrimitiveDataMatchClauses = mapM (\(pd, expr) -> (fmap stringToVar pd,) <$> desugar expr) desugarDefineWithIndices :: VarWithIndices -> Expr -> EvalM (Var, IExpr) +desugarDefineWithIndices var@(VarWithIndices _ _) expr@(LambdaExpr _ _) = do + let var' = varWithIndicesToVar var + expr' <- desugar expr + case expr' of + ILambdaExpr Nothing args body -> return (var', ILambdaExpr (Just var') args body) + _ -> return (var', expr') desugarDefineWithIndices (VarWithIndices name is) expr = do let (isSubs, indexNames) = unzip $ concatMap extractSubSupIndex is expr <- if any isExtendedIndice is @@ -477,12 +513,24 @@ else return expr body <- desugar expr let indexNamesCollection = ICollectionExpr (map IVarExpr indexNames) - let is' = map (\b -> if b then Sub () else Sup ()) isSubs + let is' = map (\b -> if b then Sub Nothing else Sup Nothing) isSubs return (Var name is', IWithSymbolsExpr indexNames (ITransposeExpr indexNamesCollection body)) +varWithIndicesToVar :: VarWithIndices -> Var +varWithIndicesToVar (VarWithIndices name is) = Var name (concatMap transVarIndex is) + +transVarIndex :: VarIndex -> [Index (Maybe Var)] +transVarIndex (VSubscript x) = [Sub (Just (stringToVar x))] +transVarIndex (VSuperscript x) = [Sup (Just (stringToVar x))] +transVarIndex (VMultiSubscript x s e) = [MultiSub (Just (stringToVar x)) s (Just (stringToVar e))] +transVarIndex (VMultiSuperscript x s e) = [MultiSup (Just (stringToVar x)) s (Just (stringToVar e))] +transVarIndex (VGroupScripts xs) = concatMap transVarIndex xs +transVarIndex (VSymmScripts xs) = concatMap transVarIndex xs +transVarIndex (VAntiSymmScripts xs) = concatMap transVarIndex xs + extractSubSupIndex :: VarIndex -> [(Bool, String)] -extractSubSupIndex (VSubscript x) = [(True, x)] -extractSubSupIndex (VSuperscript x) = [(False, x)] +extractSubSupIndex (VSubscript x) = [(True, x)] +extractSubSupIndex (VSuperscript x) = [(False, x)] extractSubSupIndex (VGroupScripts xs) = concatMap extractSubSupIndex xs extractSubSupIndex (VSymmScripts xs) = concatMap extractSubSupIndex xs extractSubSupIndex (VAntiSymmScripts xs) = concatMap extractSubSupIndex xs @@ -491,7 +539,7 @@ desugarExtendedIndices indices isSubs indexNames tensorBody = do tensorName <- fresh tensorGenExpr <- f indices (VarExpr tensorName) [] [] - let indexFunctionExpr = LambdaExpr' (map TensorArg indexNames) tensorGenExpr + let indexFunctionExpr = LambdaExpr [TensorArg $ foldr APConsPat APEmptyPat (map (TensorArg . APPatVar) (map stringToVarWithIndices indexNames))] tensorGenExpr let genTensorExpr = GenerateTensorExpr indexFunctionExpr (makeApply "tensorShape" [VarExpr tensorName]) let tensorIndices = zipWith (\isSub name -> if isSub then Subscript (VarExpr name) else Superscript (VarExpr name)) isSubs indexNames return $ LetExpr [Bind (PDPatVar tensorName) tensorBody] (IndexedExpr True genTensorExpr tensorIndices) @@ -507,7 +555,7 @@ symbols <- mapM (const fresh) isSubs let is = zipWith (\x isSub -> (if isSub then Subscript else Superscript) (VarExpr x)) symbols isSubs f indices (IndexedExpr True expr is) - (signs ++ signs') (bindings ++ bindings' ++ [Bind (foldr PDConsPat PDEmptyPat (map PDPatVar symbols)) indices']) + (signs ++ signs') (bindings ++ bindings' ++ [Bind (foldr (PDConsPat . PDPatVar) PDEmptyPat symbols) indices']) subOrSupScripts :: VarIndex -> [Bool] subOrSupScripts VSubscript{} = [True] diff --git a/hs-src/Language/Egison/Eval.hs b/hs-src/Language/Egison/Eval.hs --- a/hs-src/Language/Egison/Eval.hs +++ b/hs-src/Language/Egison/Eval.hs @@ -15,14 +15,15 @@ , evalTopExprsNoPrint , runExpr , runTopExpr + , runTopExprStr , runTopExprs -- * Load Egison files , loadEgisonLibrary , loadEgisonFile ) where -import Control.Monad.Except (throwError) -import Control.Monad.Reader (ask, asks) +import Control.Monad.Except (throwError) +import Control.Monad.Reader (ask, asks) import Control.Monad.State import Language.Egison.AST @@ -30,9 +31,9 @@ import Language.Egison.Core import Language.Egison.Data import Language.Egison.Desugar -import Language.Egison.EvalState (MonadEval(..)) +import Language.Egison.EvalState (MonadEval (..)) import Language.Egison.IExpr -import Language.Egison.MathOutput (prettyMath) +import Language.Egison.MathOutput (prettyMath) import Language.Egison.Parser @@ -45,7 +46,7 @@ evalTopExpr env topExpr = do topExpr <- desugarTopExpr topExpr case topExpr of - Nothing -> return (Nothing, env) + Nothing -> return (Nothing, env) Just topExpr -> evalTopExpr' env topExpr -- | Evaluate an Egison top expression. @@ -98,6 +99,11 @@ runTopExpr env input = readTopExpr input >>= evalTopExpr env +-- | Evaluate an Egison top expression. Input is a Haskell string. +runTopExprStr :: Env -> String -> EvalM (Maybe String, Env) +runTopExprStr env input = + readTopExpr input >>= evalTopExprStr env + -- | Evaluate Egison top expressions. Input is a Haskell string. runTopExprs :: Env -> String -> EvalM Env runTopExprs env input = @@ -144,16 +150,16 @@ env' <- recursiveBind env [(name, expr)] return (Nothing, env') evalTopExpr' env (ITest expr) = do - pushFuncName "" + pushFuncName (stringToVar "") val <- evalExprDeep env expr popFuncName return (Just val, env) evalTopExpr' env (IExecute expr) = do - pushFuncName "" + pushFuncName (stringToVar "") io <- evalExprShallow env expr case io of Value (IOFunc m) -> m >> popFuncName >> return (Nothing, env) - _ -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "io" io) evalTopExpr' env (ILoad file) = do opts <- ask when (optNoIO opts) $ throwError (Default "No IO support") diff --git a/hs-src/Language/Egison/EvalState.hs b/hs-src/Language/Egison/EvalState.hs --- a/hs-src/Language/Egison/EvalState.hs +++ b/hs-src/Language/Egison/EvalState.hs @@ -17,20 +17,22 @@ import Control.Monad.Except import Control.Monad.Trans.State.Strict +import Language.Egison.IExpr + newtype EvalState = EvalState -- Names of called functions for improved error message - { funcNameStack :: [String] + { funcNameStack :: [Var] } initialEvalState :: EvalState initialEvalState = EvalState { funcNameStack = [] } class (Applicative m, Monad m) => MonadEval m where - pushFuncName :: String -> m () - topFuncName :: m String + pushFuncName :: Var -> m () + topFuncName :: m Var popFuncName :: m () - getFuncNameStack :: m [String] + getFuncNameStack :: m [Var] instance Monad m => MonadEval (StateT EvalState m) where pushFuncName name = do @@ -50,7 +52,7 @@ popFuncName = lift popFuncName getFuncNameStack = lift getFuncNameStack -mLabelFuncName :: MonadEval m => Maybe String -> m a -> m a +mLabelFuncName :: MonadEval m => Maybe Var -> m a -> m a mLabelFuncName Nothing m = m mLabelFuncName (Just name) m = do pushFuncName name diff --git a/hs-src/Language/Egison/IExpr.hs b/hs-src/Language/Egison/IExpr.hs --- a/hs-src/Language/Egison/IExpr.hs +++ b/hs-src/Language/Egison/IExpr.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {- | Module : Language.Egison.IExpr @@ -21,6 +20,7 @@ , IPrimitiveDataPattern , Var (..) , stringToVar + , extractNameFromVar , Index (..) , extractSupOrSubIndex , extractIndex @@ -32,14 +32,10 @@ , PDPatternBase (..) ) where -import Data.Hashable (Hashable) +import Data.Hashable import GHC.Generics (Generic) -import Language.Egison.AST ( ConstantExpr (..) - , PMMode (..) - , PrimitivePatPattern (..) - , PDPatternBase (..) - ) +import Language.Egison.AST (ConstantExpr (..), PDPatternBase (..), PMMode (..), PrimitivePatPattern (..)) data ITopExpr = IDefine Var IExpr @@ -63,7 +59,7 @@ | IJoinExpr IExpr IExpr | IHashExpr [(IExpr, IExpr)] | IVectorExpr [IExpr] - | ILambdaExpr (Maybe String) [String] IExpr + | ILambdaExpr (Maybe Var) [Var] IExpr | IMemoizedLambdaExpr [String] IExpr | ICambdaExpr String IExpr | IPatternFunctionExpr [String] IPattern @@ -127,6 +123,8 @@ data Index a = Sub a | Sup a + | MultiSub a Integer a + | MultiSup a Integer a | SupSub a | User a | DF Integer Integer @@ -145,14 +143,32 @@ extractIndex (User x) = x extractIndex DF{} = undefined -data Var = Var String [Index ()] +data Var = Var String [Index (Maybe Var)] + deriving (Generic, Show) + +-- for eq and hashable +data Var' = Var' String [Index ()] deriving (Eq, Generic, Show) -instance Hashable (Index ()) -instance Hashable Var +instance Eq Var where + Var name (MultiSup _ _ _:_) == Var name' is' = Var name [] == Var name' is' + Var name (MultiSub _ _ _:_) == Var name' is' = Var name [] == Var name' is' + Var name is == Var name' (MultiSup _ _ _:_) = Var name is == Var name' [] + Var name is == Var name' (MultiSub _ _ _:_) = Var name is == Var name' [] + Var name is == Var name' is' = Var' name (map (fmap (\_ -> ())) is) == Var' name' (map (fmap (\_ -> ())) is') +instance Hashable a => Hashable (Index a) +instance Hashable Var' +instance Hashable Var where + hashWithSalt salt (Var name (MultiSup _ _ _:_)) = hashWithSalt salt (Var' name []) + hashWithSalt salt (Var name (MultiSub _ _ _:_)) = hashWithSalt salt (Var' name []) + hashWithSalt salt (Var name is) = hashWithSalt salt (Var' name (map (fmap (\_ -> ())) is)) + stringToVar :: String -> Var stringToVar name = Var name [] + +extractNameFromVar :: Var -> String +extractNameFromVar (Var name _) = name makeIApply :: String -> [IExpr] -> IExpr makeIApply func args = IApplyExpr (IVarExpr func) args diff --git a/hs-src/Language/Egison/MList.hs b/hs-src/Language/Egison/MList.hs --- a/hs-src/Language/Egison/MList.hs +++ b/hs-src/Language/Egison/MList.hs @@ -19,8 +19,8 @@ , mAny ) where -import Prelude hiding (mappend, mconcat,) import Data.Sequence (Seq) +import Prelude hiding (mappend, mconcat) data MList m a = MNil | MCons a (m (MList m a)) diff --git a/hs-src/Language/Egison/Match.hs b/hs-src/Language/Egison/Match.hs --- a/hs-src/Language/Egison/Match.hs +++ b/hs-src/Language/Egison/Match.hs @@ -37,7 +37,7 @@ } instance Show MatchingState where - show ms = "(MState " ++ unwords ["_", "_", "_", show (mStateBindings ms), show (mTrees ms)] ++ ")" + show ms = "(MState " ++ unwords ["_", "_", "_", show (mStateBindings ms), show (mTrees ms)] ++ ")" data MatchingTree = MAtom IPattern WHNFData Matcher @@ -53,9 +53,9 @@ | ForallPatContext [Matcher] [WHNFData] nullMState :: MatchingState -> Bool -nullMState MState{ mTrees = [] } = True +nullMState MState{ mTrees = [] } = True nullMState MState{ mTrees = MNode _ state : _ } = nullMState state -nullMState _ = False +nullMState _ = False -- -- Monads diff --git a/hs-src/Language/Egison/Math.hs b/hs-src/Language/Egison/Math.hs --- a/hs-src/Language/Egison/Math.hs +++ b/hs-src/Language/Egison/Math.hs @@ -27,7 +27,7 @@ , mathNegate ) where -import Language.Egison.Math.Expr import Language.Egison.Math.Arith +import Language.Egison.Math.Expr import Language.Egison.Math.Normalize import Language.Egison.Math.Rewrite diff --git a/hs-src/Language/Egison/Math/Arith.hs b/hs-src/Language/Egison/Math/Arith.hs --- a/hs-src/Language/Egison/Math/Arith.hs +++ b/hs-src/Language/Egison/Math/Arith.hs @@ -32,8 +32,8 @@ mathMult (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathMultPoly m1 m2) (mathMultPoly n1 n2) mathMultPoly :: PolyExpr -> PolyExpr -> PolyExpr -mathMultPoly (Plus []) (Plus _) = Plus [] -mathMultPoly (Plus _) (Plus []) = Plus [] +mathMultPoly (Plus []) (Plus _) = Plus [] +mathMultPoly (Plus _) (Plus []) = Plus [] mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> Plus (map (\(Term b ys) -> Term (a * b) (xs ++ ys)) ts2)) ts1) mathDiv :: ScalarData -> ScalarData -> ScalarData diff --git a/hs-src/Language/Egison/Math/Expr.hs b/hs-src/Language/Egison/Math/Expr.hs --- a/hs-src/Language/Egison/Math/Expr.hs +++ b/hs-src/Language/Egison/Math/Expr.hs @@ -45,13 +45,13 @@ , mathNegate ) where -import Prelude hiding (foldr, mappend, mconcat) -import Data.List (intercalate) +import Data.List (intercalate) +import Prelude hiding (foldr, mappend, mconcat) -import Control.Monad ( MonadPlus(..) ) import Control.Egison +import Control.Monad (MonadPlus (..)) -import Language.Egison.IExpr (Index(..)) +import Language.Egison.IExpr (Index (..)) -- -- Data @@ -76,7 +76,7 @@ = Symbol Id String [Index ScalarData] | Apply ScalarData [ScalarData] | Quote ScalarData - | FunctionData ScalarData [ScalarData] [ScalarData] [Index ScalarData] -- fnname argnames args indices + | FunctionData ScalarData [ScalarData] [ScalarData] -- fnname argnames args deriving Eq type Id = String @@ -103,12 +103,12 @@ symbolM :: SymbolM -> p -> Eql symbolM SymbolM _ = Eql -func :: Pattern (PP ScalarData, PP [ScalarData], PP [Index ScalarData]) - SymbolM SymbolExpr (ScalarData, [ScalarData], [Index ScalarData]) -func _ _ (FunctionData name _ args js) = pure (name, args, js) +func :: Pattern (PP ScalarData, PP [ScalarData]) + SymbolM SymbolExpr (ScalarData, [ScalarData]) +func _ _ (FunctionData name _ args) = pure (name, args) func _ _ _ = mzero -funcM :: SymbolM -> SymbolExpr -> (ScalarM, List ScalarM, Multiset Eql) -funcM SymbolM _ = (ScalarM, List ScalarM, Multiset Eql) +funcM :: SymbolM -> SymbolExpr -> (ScalarM, List ScalarM) +funcM SymbolM _ = (ScalarM, List ScalarM) apply :: Pattern (PP String, PP [ScalarData]) SymbolM SymbolExpr (String, [ScalarData]) apply _ _ (Apply (SingleSymbol (Symbol _ fn _)) args) = pure (fn, args) @@ -238,24 +238,25 @@ instance Printable SymbolExpr where isAtom Symbol{} = True isAtom (Apply _ []) = True + isAtom Quote{} = True isAtom _ = False pretty (Symbol _ (':':':':':':_) []) = "#" - pretty (Symbol _ s []) = s - pretty (Symbol _ s js) = s ++ concatMap show js - pretty (Apply fn mExprs) = unwords (map pretty' (fn : mExprs)) - pretty (Quote mExprs) = "'" ++ pretty' mExprs - pretty (FunctionData name _ _ js) = pretty name ++ concatMap show js + pretty (Symbol _ s []) = s + pretty (Symbol _ s js) = s ++ concatMap show js + pretty (Apply fn mExprs) = unwords (map pretty' (fn : mExprs)) + pretty (Quote mExprs) = "`" ++ pretty' mExprs + pretty (FunctionData name _ _) = pretty name instance Printable TermExpr where isAtom (Term _ []) = True isAtom (Term 1 [_]) = True isAtom _ = False - pretty (Term a []) = show a - pretty (Term 1 xs) = intercalate " * " (map prettyPoweredSymbol xs) + pretty (Term a []) = show a + pretty (Term 1 xs) = intercalate " * " (map prettyPoweredSymbol xs) pretty (Term (-1) xs) = "- " ++ intercalate " * " (map prettyPoweredSymbol xs) - pretty (Term a xs) = intercalate " * " (show a : map prettyPoweredSymbol xs) + pretty (Term a xs) = intercalate " * " (show a : map prettyPoweredSymbol xs) prettyPoweredSymbol :: (SymbolExpr, Integer) -> String prettyPoweredSymbol (x, 1) = show x diff --git a/hs-src/Language/Egison/Math/Normalize.hs b/hs-src/Language/Egison/Math/Normalize.hs --- a/hs-src/Language/Egison/Math/Normalize.hs +++ b/hs-src/Language/Egison/Math/Normalize.hs @@ -122,7 +122,7 @@ f [] = [] f (t:ts) = match dfs (t, ts) (Pair TermM (Multiset TermM)) - [ [mc| (term $a $xs, term $b ($ys & equalMonomial $sgn #xs) : $tss) -> - f (Term (sgn * a + b) ys : tss) |] + [ [mc| (term $a $xs, term $b (equalMonomial $sgn #xs) : $tss) -> + f (Term (sgn * a + b) xs : tss) |] , [mc| _ -> t : f ts |] ] diff --git a/hs-src/Language/Egison/Math/Rewrite.hs b/hs-src/Language/Egison/Math/Rewrite.hs --- a/hs-src/Language/Egison/Math/Rewrite.hs +++ b/hs-src/Language/Egison/Math/Rewrite.hs @@ -164,13 +164,9 @@ let d@(Term c z) = termsGcd [Term n x, Term m y] Term n' x' = mathDivideTerm (Term n x) d Term m' y' = mathDivideTerm (Term m y) d - sqrtxy = (if x' == [] then [] else [(makeApply "sqrt" [SingleTerm 1 x'], 1)]) ++ - (if y' == [] then [] else [(makeApply "sqrt" [SingleTerm 1 y'], 1)]) - in mathMult - (SingleTerm c z) - (SingleTerm - a - ((makeApply "sqrt" [SingleTerm (n' * m') []], 1) : sqrtxy ++ xss)) |] + in case (n' * m', Term n' x', Term m' y') of + (1, Term _ [], Term _ []) -> mathMult (SingleTerm c z) (SingleTerm a xss) + (_, _, _) -> mathMult (SingleTerm c z) (SingleTerm a ((makeApply "sqrt" [SingleTerm (n' * m') (x' ++ y')], 1) : xss)) |] , [mc| _ -> SingleTerm a xs |] ] @@ -186,7 +182,7 @@ ] rewriteRtu :: ScalarData -> ScalarData -rewriteRtu = mapTerms f +rewriteRtu = mapTerms' g . mapTerms f where f term@(Term a xs) = match dfs xs (Multiset (Pair SymbolM Eql)) @@ -194,6 +190,14 @@ Term a ((rtun, k `mod` n) : r) |] , [mc| _ -> term |] ] + g (Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"rtu" [singleTerm $n #1 []] & $rtun, ?(== n - 1)) : $mr -> + mathMult + (foldl mathMinus (SingleTerm (-1) []) (map (\k -> SingleTerm 1 [(rtun, k)]) [1..(n-2)])) + (g (Term a mr)) |] + , [mc| _ -> SingleTerm a xs |] + ] rewriteDd :: ScalarData -> ScalarData rewriteDd (Div (Plus p1) (Plus p2)) = @@ -201,8 +205,8 @@ where rewriteDdPoly poly = match dfs poly (Multiset TermM) - [ [mc| term $a (($f & func $g $arg $js, $n) : $mr) : - term $b ((func #g #arg #js, #n) : #mr) : $pr -> + [ [mc| term $a (($f & func $g $arg, $n) : $mr) : + term $b ((func #g #arg, #n) : #mr) : $pr -> rewriteDdPoly (Term (a + b) ((f, n) : mr) : pr) |] , [mc| _ -> poly |] ] 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 @@ -20,21 +20,21 @@ , removeShebang , readUTF8File ) where - -import Control.Monad.Except (lift, liftIO, throwError) -import Control.Monad.State (unless) -import Control.Monad.Reader (asks, local) -import System.Directory (doesFileExist, getHomeDirectory) +import Control.Monad.Except (lift, liftIO, throwError) +import Control.Monad.Reader (asks, local) +import Control.Monad.State (unless) + +import System.Directory (doesFileExist, getHomeDirectory) import System.IO import Language.Egison.AST import Language.Egison.CmdOptions import Language.Egison.Data +import qualified Language.Egison.Parser.NonS as NonS +import qualified Language.Egison.Parser.SExpr as SExpr import Language.Egison.RState -import qualified Language.Egison.Parser.SExpr as SExpr -import qualified Language.Egison.Parser.NonS as NonS -import Paths_egison (getDataFileName) +import Paths_egison (getDataFileName) readTopExprs :: String -> EvalM [TopExpr] readTopExprs expr = do diff --git a/hs-src/Language/Egison/Parser/NonS.hs b/hs-src/Language/Egison/Parser/NonS.hs --- a/hs-src/Language/Egison/Parser/NonS.hs +++ b/hs-src/Language/Egison/Parser/NonS.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {- | Module : Language.Egison.Parser.NonS @@ -23,8 +22,9 @@ import Data.Char (isAsciiUpper, isLetter) import Data.Either (isRight) +import Data.Function (on) import Data.Functor (($>)) -import Data.List (groupBy, insertBy) +import Data.List (groupBy, insertBy, sortOn) import Data.Maybe (isJust, isNothing) import Data.Text (pack) @@ -33,7 +33,7 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L -import Language.Egison.AST hiding (Assoc(..)) +import Language.Egison.AST hiding (Assoc (..)) import qualified Language.Egison.AST as E import Language.Egison.RState @@ -122,7 +122,7 @@ return (InfixDecl isPattern newop) where check :: String -> Parser String - check ('!':_) = fail $ "cannot declare infix starting with '!'" + check ('!':_) = fail "cannot declare infix starting with '!'" check x | x `elem` reservedOp = fail $ show x ++ " cannot be a new infix" | otherwise = return x @@ -151,7 +151,7 @@ body <- exprWithoutWhere bindings <- optional (reserved "where" >> alignSome binding) return $ case bindings of - Nothing -> body + Nothing -> body Just bindings -> LetRecExpr bindings body exprWithoutWhere :: Parser Expr @@ -186,7 +186,8 @@ makeExprTable :: [Op] -> [[Operator Parser Expr]] makeExprTable ops = -- Generate binary operator table from |ops| - map (map toOperator) (groupBy (\x y -> priority x == priority y) ops) + reverse $ map (map snd) $ groupBy ((==) `on` fst) $ sortOn fst $ + (infixFuncOpPriority, infixFuncOperator) : map (\op -> (priority op, toOperator op)) ops where -- notFollowedBy (in unary and binary) is necessary for section expression. unary :: String -> Parser (Expr -> Expr) @@ -207,6 +208,17 @@ E.InfixN -> InfixN (binary op) E.Prefix -> Prefix (unary (repr op)) + infixFuncOperator :: Operator Parser Expr + infixFuncOperator = InfixL $ InfixExpr <$> infixFuncOp + +infixFuncOp :: Parser Op +infixFuncOp = do + func <- try (indented >> between (symbol "`") (symbol "`") ident) + return $ Op { repr = func, priority = infixFuncOpPriority, assoc = E.InfixL, isWedge = False } + +infixFuncOpPriority :: Int +infixFuncOpPriority = 7 + ifExpr :: Parser Expr ifExpr = reserved "if" >> IfExpr <$> expr <* reserved "then" <*> expr <* reserved "else" <*> expr @@ -266,7 +278,12 @@ argPatternAtom = APWildCard <$ symbol "_" <|> APTuplePat <$> parens (sepBy arg comma) - <|> APPatVar <$> ident + <|> collectionPattern + <|> APPatVar <$> varWithIndicesLiteral + where + collectionPattern = brackets $ do + elems <- sepBy arg comma + return $ foldr APConsPat APEmptyPat elems letExpr :: Parser Expr letExpr = do @@ -388,7 +405,7 @@ leftSection :: Parser Expr leftSection = do ops <- gets exprOps - op <- choice $ map (infixLiteral . repr) ops + op <- choice $ infixFuncOp : map (infixLiteral . repr) ops rarg <- optional expr case rarg of -- Disabling for now... (See issue 159) @@ -402,7 +419,7 @@ rightSection = do ops <- gets exprOps larg <- opExpr - op <- choice $ map (infixLiteral . repr) ops + op <- choice $ infixFuncOp : map (infixLiteral . repr) ops case larg of -- InfixExpr op' _ _ -- | assoc op' /= InfixL && priority op >= priority op' -> @@ -457,7 +474,9 @@ -- Atomic expressions without index atomExpr' :: Parser Expr -atomExpr' = anonParamFuncExpr -- must come before |constantExpr| +atomExpr' = anonParamFuncExpr -- must come before |constantExpr| + <|> anonTupleParamFuncExpr -- must come before |tupleOrParenExpr| + <|> anonListParamFuncExpr -- must come before |collectionExpr| <|> ConstantExpr <$> constantExpr <|> FreshVarExpr <$ symbol "#" <|> VarExpr <$> ident @@ -465,8 +484,8 @@ <|> collectionExpr <|> tupleOrParenExpr <|> hashExpr - <|> QuoteExpr <$> (char '\'' >> atomExpr') -- must come after |constantExpr| - <|> QuoteSymbolExpr <$> (char '`' >> atomExpr') + <|> QuoteExpr <$> (try (symbol "`" <* notFollowedBy ident) >> atomExpr') -- must come after |constantExpr| + <|> QuoteSymbolExpr <$> try (char '\'' >> atomExpr') <|> AnonParamExpr <$> try (char '%' >> positiveIntegerLiteral) "atomic expression" @@ -476,6 +495,16 @@ body <- atomExpr -- No space after '#' return $ AnonParamFuncExpr n body +anonTupleParamFuncExpr :: Parser Expr +anonTupleParamFuncExpr = do + n <- try (char '(' *> L.decimal <* string ")#") + AnonTupleParamFuncExpr n <$> atomExpr + +anonListParamFuncExpr :: Parser Expr +anonListParamFuncExpr = do + n <- try (char '[' *> L.decimal <* string "]#") + AnonListParamFuncExpr n <$> atomExpr + constantExpr :: Parser ConstantExpr constantExpr = numericExpr <|> BoolExpr <$> boolLiteral @@ -683,11 +712,24 @@ lexeme (VarWithIndices <$> ident' <*> some varIndex) varIndex :: Parser VarIndex -varIndex = (char '_' >> VSubscript <$> ident') - <|> (char '~' >> VSuperscript <$> ident') +varIndex = (char '_' >> subscript) + <|> (char '~' >> supscript) <|> parens (VGroupScripts <$> some varIndex) <|> braces (VSymmScripts <$> some varIndex) <|> brackets (VAntiSymmScripts <$> some varIndex) + where + subscript = VSubscript <$> ident' + <|> (do + (n, s) <- parens $ (,) <$> ident' <*> (char '_' >> positiveIntegerLiteral) + _ <- string "..." >> char '_' + e <- parens $ string n >> char '_' >> ident' + return (VMultiSubscript n s e)) + supscript = VSuperscript <$> ident' + <|> (do + (n, s) <- parens $ (,) <$> ident' <*> (char '_' >> positiveIntegerLiteral) + _ <- string "..." >> char '~' + e <- parens $ string n >> char '_' >> ident' + return (VMultiSuperscript n s e)) patVarLiteral :: Parser String patVarLiteral = char '$' >> ident diff --git a/hs-src/Language/Egison/Parser/SExpr.hs b/hs-src/Language/Egison/Parser/SExpr.hs --- a/hs-src/Language/Egison/Parser/SExpr.hs +++ b/hs-src/Language/Egison/Parser/SExpr.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-all #-} -- Since we will soon deprecate this parser +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-all #-} -- Since we will soon deprecate this parser {- | Module : Language.Egison.Parser.SExpr @@ -18,21 +17,20 @@ , parseExpr ) where -import Control.Applicative (pure, (*>), (<$>), (<*), (<*>)) -import Control.Monad.Except (throwError) -import Control.Monad.Identity (Identity) +import Control.Applicative (pure, (*>), (<$>), (<*), (<*>)) +import Control.Monad.Except (throwError) +import Control.Monad.Identity (Identity) -import Data.Char (isLower, isUpper, toUpper) +import Data.Char (isLower, isUpper, toUpper) import Data.Either -import Data.Functor (($>)) -import Data.List.Split (splitOn) +import Data.Functor (($>)) import Data.Ratio -import qualified Data.Set as Set -import qualified Data.Text as T +import qualified Data.Set as Set +import qualified Data.Text as T import Text.Parsec import Text.Parsec.String -import qualified Text.Parsec.Token as P +import qualified Text.Parsec.Token as P import Language.Egison.AST @@ -195,12 +193,12 @@ isElementExpr _ = False f :: [Expr] -> [InnerExpr] -> Expr - f xs [] = CollectionExpr xs - f xs [ElementExpr y] = CollectionExpr (xs ++ [y]) - f [] [SubCollectionExpr y] = y - f [x] [SubCollectionExpr y] = ConsExpr x y - f xs [SubCollectionExpr y] = JoinExpr (CollectionExpr xs) y - f xs (ElementExpr y : ys) = f (xs ++ [y]) ys + f xs [] = CollectionExpr xs + f xs [ElementExpr y] = CollectionExpr (xs ++ [y]) + f [] [SubCollectionExpr y] = y + f [x] [SubCollectionExpr y] = ConsExpr x y + f xs [SubCollectionExpr y] = JoinExpr (CollectionExpr xs) y + f xs (ElementExpr y : ys) = f (xs ++ [y]) ys f [] (SubCollectionExpr y : ys) = JoinExpr y (f [] ys) f [x] (SubCollectionExpr y : ys) = ConsExpr x (JoinExpr y (f [] ys)) f xs (SubCollectionExpr y : ys) = JoinExpr (CollectionExpr xs) (JoinExpr y (f [] ys)) @@ -385,7 +383,7 @@ <|> try (TensorArg <$> (char '%' >> argPattern)) argPattern :: Parser ArgPattern -argPattern = APPatVar <$> ident +argPattern = APPatVar <$> identVarWithIndices seqExpr :: Parser Expr seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr @@ -404,7 +402,7 @@ let n = toInteger (length vars) args' = f args 1 in return $ AnonParamFuncExpr n $ ApplyExpr func args' - | all (not . null) vars -> + | not (any null vars) -> let ns = Set.fromList $ map read vars n = Set.size ns in if Set.findMin ns == 1 && Set.findMax ns == n @@ -417,9 +415,9 @@ arg = try (Right <$> expr) <|> char '$' *> (Left <$> option "" index) index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit - f [] _ = [] - f (Left _ : args) n = AnonParamExpr n : f args (n + 1) - f (Right expr : args) n = expr : f args n + f [] _ = [] + f (Left _ : args) n = AnonParamExpr n : f args (n + 1) + f (Right expr : args) n = expr : f args n g (Left arg) = AnonParamExpr (read arg) g (Right expr) = expr @@ -859,8 +857,17 @@ , ("rdc", "init") ] +splitOn :: Eq a => a -> [a] -> [[a]] +splitOn sep list = + case span (/= sep) list of + ([], []) -> [] + ([], _ : t) -> splitOn sep t + (h, []) -> [h] + (h, _ : t) -> h : splitOn sep t + -- Translate identifiers for Non-S syntax toCamelCase :: String -> String +toCamelCase "-" = "-" toCamelCase "-'" = "-'" toCamelCase "f.-'" = "f.-'" toCamelCase "b.." = "b." @@ -870,8 +877,8 @@ toCamelCase (reverse -> 'm':'/':xs) = toCamelCase (reverse xs ++ "-as") toCamelCase x = - let heads:tails = splitOn "-" x + let heads:tails = splitOn '-' x in concat $ heads : map capitalize tails where - capitalize [] = "-" + capitalize [] = "-" capitalize (x:xs) = toUpper x : xs diff --git a/hs-src/Language/Egison/Pretty.hs b/hs-src/Language/Egison/Pretty.hs --- a/hs-src/Language/Egison/Pretty.hs +++ b/hs-src/Language/Egison/Pretty.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} {- | @@ -18,11 +16,11 @@ , showTSV ) where -import Data.Foldable (toList) -import Data.List (intercalate) +import Data.Foldable (toList) +import Data.List (intercalate) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String (renderString) -import Text.Show.Unicode (ushow) +import Text.Show.Unicode (ushow) import Language.Egison.AST import Language.Egison.Data @@ -51,8 +49,8 @@ pretty (BoolExpr x) = pretty x pretty (IntegerExpr x) = pretty x pretty (FloatExpr x) = pretty x - pretty SomethingExpr = pretty "something" - pretty UndefinedExpr = pretty "undefined" + pretty SomethingExpr = pretty "something" + pretty UndefinedExpr = pretty "undefined" instance Pretty Expr where pretty (ConstantExpr c) = pretty c @@ -194,8 +192,8 @@ pretty (VarWithIndices xs is) = pretty xs <> hcat (map pretty is) instance Pretty VarIndex where - pretty (VSubscript x) = pretty ('_' : x) - pretty (VSuperscript x) = pretty ('~' : x) + pretty (VSubscript x) = pretty ('_' : x) + pretty (VSuperscript x) = pretty ('~' : x) pretty (VSymmScripts xs) = pretty '{' <> hcat (map pretty xs) <> pretty '}' pretty (VAntiSymmScripts xs) = pretty '[' <> hcat (map pretty xs) <> pretty ']' @@ -217,12 +215,12 @@ pretty _ = undefined instance (Pretty a, Complex a) => Pretty (IndexExpr a) where - pretty (Subscript i) = pretty '_' <> pretty' i - pretty (Superscript i) = pretty '~' <> pretty' i - pretty (SupSubscript i) = pretty "~_" <> pretty' i - pretty (MultiSubscript i j) = pretty '_' <> pretty' i <> pretty "..._" <> pretty' j + pretty (Subscript i) = pretty '_' <> pretty' i + pretty (Superscript i) = pretty '~' <> pretty' i + pretty (SupSubscript i) = pretty "~_" <> pretty' i + pretty (MultiSubscript i j) = pretty '_' <> pretty' i <> pretty "..._" <> pretty' j pretty (MultiSuperscript i j) = pretty '~' <> pretty' i <> pretty "...~" <> pretty' j - pretty (Userscript i) = pretty '|' <> pretty' i + pretty (Userscript i) = pretty '|' <> pretty' i instance Pretty Pattern where pretty WildCard = pretty "_" @@ -259,9 +257,9 @@ pretty SeqNilPat = pretty "{}" pretty (SeqConsPat p1 p2) = listoid "{" "}" (f p1 p2) where - f p1 SeqNilPat = [pretty p1] + f p1 SeqNilPat = [pretty p1] f p1 (SeqConsPat p2 p3) = pretty p1 : f p2 p3 - f p1 p2 = [pretty p1, pretty p2] + f p1 p2 = [pretty p1, pretty p2] pretty LaterPatVar = pretty "@" pretty (DApplyPat p ps) = applyLike (map pretty' (p : ps)) pretty e = pretty (show e) @@ -273,21 +271,21 @@ pretty (LoopRange from to pat) = tupled [pretty from, pretty to, pretty pat] instance Pretty PrimitivePatPattern where - pretty PPWildCard = pretty "_" - pretty PPPatVar = pretty "$" - pretty (PPValuePat x) = pretty ('#' : '$' : x) + pretty PPWildCard = pretty "_" + pretty PPPatVar = pretty "$" + pretty (PPValuePat x) = pretty ('#' : '$' : x) pretty (PPInductivePat x pppats) = hsep (pretty x : map pretty pppats) - pretty (PPTuplePat pppats) = tupled (map pretty pppats) + pretty (PPTuplePat pppats) = tupled (map pretty pppats) instance Pretty PrimitiveDataPattern where - pretty PDWildCard = pretty "_" - pretty (PDPatVar x) = pretty x + pretty PDWildCard = pretty "_" + pretty (PDPatVar x) = pretty x pretty (PDInductivePat x pdpats) = applyLike (pretty x : map pretty' pdpats) - pretty (PDTuplePat pdpats) = tupled (map pretty pdpats) - pretty PDEmptyPat = pretty "[]" - pretty (PDConsPat pdp1 pdp2) = pretty'' pdp1 <+> pretty "::" <+> pretty'' pdp2 - pretty (PDSnocPat pdp1 pdp2) = applyLike [pretty "snoc", pretty' pdp1, pretty' pdp2] - pretty (PDConstantPat expr) = pretty expr + pretty (PDTuplePat pdpats) = tupled (map pretty pdpats) + pretty PDEmptyPat = pretty "[]" + pretty (PDConsPat pdp1 pdp2) = pretty'' pdp1 <+> pretty "::" <+> pretty'' pdp2 + pretty (PDSnocPat pdp1 pdp2) = applyLike [pretty "snoc", pretty' pdp1, pretty' pdp2] + pretty (PDConstantPat expr) = pretty expr instance Pretty Op where pretty op | isWedge op = pretty ("!" ++ repr op) @@ -338,11 +336,11 @@ isAtom TransposeExpr{} = False isAtom _ = True - isAtomOrApp ApplyExpr{} = True - isAtomOrApp e = isAtom e + isAtomOrApp ApplyExpr{} = True + isAtomOrApp e = isAtom e - isInfix InfixExpr{} = True - isInfix _ = False + isInfix InfixExpr{} = True + isInfix _ = False instance Complex a => Complex (Arg a) where isAtom (TensorArg x) = isAtom x @@ -363,11 +361,11 @@ isInfix _ = False instance Complex Pattern where - isAtom (LetPat _ _) = False + isAtom LetPat{} = False isAtom (InductivePat _ []) = True isAtom (InductivePat _ _) = False - isAtom (InfixPat _ _ _) = False - isAtom (LoopPat _ _ _ _) = False + isAtom InfixPat{} = False + isAtom LoopPat{} = False isAtom (PApplyPat _ []) = True isAtom (PApplyPat _ _) = False isAtom _ = True @@ -382,8 +380,8 @@ instance Complex PrimitiveDataPattern where isAtom (PDInductivePat _ []) = True isAtom (PDInductivePat _ _) = False - isAtom (PDConsPat _ _) = False - isAtom (PDSnocPat _ _) = False + isAtom PDConsPat{} = False + isAtom PDSnocPat{} = False isAtom _ = True isAtomOrApp PDInductivePat{} = True @@ -404,7 +402,7 @@ -- Display "hoge" instead of "() := hoge" prettyDoBinds :: BindingExpr -> Doc ann prettyDoBinds (Bind (PDTuplePat []) expr) = pretty expr -prettyDoBinds bind = pretty "let" <+> pretty bind +prettyDoBinds bind = pretty "let" <+> pretty bind prettyMatch :: Expr -> [MatchClause] -> Doc ann prettyMatch matcher clauses = @@ -449,8 +447,8 @@ showTSV :: EgisonValue -> String showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (show val) (map show vals) -showTSV (Collection vals) = intercalate "\t" (map show (toList vals)) -showTSV val = show val +showTSV (Collection vals) = intercalate "\t" (map show (toList vals)) +showTSV val = show val -- -- Pretty printer for error messages diff --git a/hs-src/Language/Egison/PrettyMath/AST.hs b/hs-src/Language/Egison/PrettyMath/AST.hs --- a/hs-src/Language/Egison/PrettyMath/AST.hs +++ b/hs-src/Language/Egison/PrettyMath/AST.hs @@ -13,12 +13,12 @@ , parseExpr ) where -import Data.Foldable (toList) +import Data.Foldable (toList) import Text.ParserCombinators.Parsec hiding (spaces) -import qualified Language.Egison.Data as E -import qualified Language.Egison.IExpr as E -import qualified Language.Egison.Math.Expr as E +import qualified Language.Egison.Data as E +import qualified Language.Egison.IExpr as E +import qualified Language.Egison.Math.Expr as E data MathExpr = Atom String [MathIndex] @@ -49,19 +49,24 @@ toMathExpr :: a -> MathExpr instance ToMathExpr E.EgisonValue where - toMathExpr (E.ScalarData s) = toMathExpr s - toMathExpr (E.Tuple es) = Tuple (map toMathExpr es) + toMathExpr (E.ScalarData s) = toMathExpr s + toMathExpr (E.Tuple es) = Tuple (map toMathExpr es) toMathExpr (E.Collection es) = Collection (map toMathExpr (toList es)) - toMathExpr (E.TensorData t) = toMathExpr t - toMathExpr e = Atom (show e) [] + toMathExpr (E.TensorData t) = toMathExpr t + toMathExpr e = Atom (show e) [] instance ToMathExpr a => ToMathExpr (E.Tensor a) where - toMathExpr (E.Scalar _) = undefined - toMathExpr (E.Tensor _ xs js) = Tensor (map toMathExpr (toList xs)) (map toMathIndex js) + toMathExpr (E.Scalar _) = undefined + toMathExpr (E.Tensor [_] xs js) = Tensor (map toMathExpr (toList xs)) (map toMathIndex js) + toMathExpr (E.Tensor [_, n] xs js) = Tensor (f (fromIntegral n) (map toMathExpr (toList xs))) (map toMathIndex js) + where + f _ [] = [] + f n xs = Tensor (take n xs) [] : f n (drop n xs) + toMathExpr (E.Tensor _ _ _) = undefined instance ToMathExpr E.ScalarData where toMathExpr (E.Div p (E.Plus [E.Term 1 []])) = toMathExpr p - toMathExpr (E.Div p1 p2) = Div (toMathExpr p1) (toMathExpr p2) + toMathExpr (E.Div p1 p2) = Div (toMathExpr p1) (toMathExpr p2) instance ToMathExpr E.PolyExpr where toMathExpr (E.Plus []) = Atom "0" [] @@ -100,12 +105,21 @@ (Atom "^" [], [x, y]) -> Power (toMathExpr x) (toMathExpr y) _ -> Func (toMathExpr fn) (map toMathExpr mExprs) toMathExpr (E.Quote mExpr) = Quote (toMathExpr mExpr) - toMathExpr (E.FunctionData _ _ _ _) = undefined -- TODO + toMathExpr (E.FunctionData (E.SingleTerm 1 [(E.Symbol _ s js, 1)]) _ _) = toMathExpr' js (Atom s []) + where + toMathExpr' [] acc = acc + toMathExpr' (E.User x:js) (Partial e ps) = + toMathExpr' js (Partial e (ps ++ [toMathExpr x])) + toMathExpr' (E.User x:js) e@Atom{} = + toMathExpr' js (Partial e [toMathExpr x]) + toMathExpr' (j:js) (Atom e is) = + toMathExpr' js (Atom e (is ++ [toMathIndex j])) + toMathExpr' _ _ = undefined -- TODO toMathIndex :: ToMathExpr a => E.Index a -> MathIndex toMathIndex (E.Sub x) = Sub (toMathExpr x) toMathIndex (E.Sup x) = Super (toMathExpr x) -toMathIndex _ = undefined -- TODO +toMathIndex _ = undefined -- TODO -- -- Parser diff --git a/hs-src/Language/Egison/PrettyMath/AsciiMath.hs b/hs-src/Language/Egison/PrettyMath/AsciiMath.hs --- a/hs-src/Language/Egison/PrettyMath/AsciiMath.hs +++ b/hs-src/Language/Egison/PrettyMath/AsciiMath.hs @@ -7,7 +7,7 @@ ( showMathExpr ) where -import Data.List (intercalate) +import Data.List (intercalate) import Language.Egison.PrettyMath.AST @@ -18,11 +18,11 @@ showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs where showMathExprForPlus :: [MathExpr] -> String - showMathExprForPlus [] = "" - showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs + showMathExprForPlus [] = "" + showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs - showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ " " ++ showMathExprForPlus xs - showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs + showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ " " ++ showMathExprForPlus xs + showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs showMathExpr (Multiply []) = "" showMathExpr (Multiply [x]) = showMathExpr x showMathExpr (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExpr (Multiply xs) @@ -36,14 +36,14 @@ showMathExpr (Tensor lvs mis) | null mis = "(" ++ showMathExprArg lvs ++ ")" | not (any isSub mis) = "(" ++ showMathExprArg lvs ++ ")^(" ++ showMathExprIndices mis ++ ")" - | not (any (not . isSub) mis) = "(" ++ showMathExprArg lvs ++ ")_(" ++ showMathExprIndices mis ++ ")" + | all isSub mis = "(" ++ showMathExprArg lvs ++ ")_(" ++ showMathExprIndices mis ++ ")" | otherwise = "(" ++ showMathExprArg lvs ++ ")_(" ++ showMathExprIndices (filter isSub mis) ++ ")^(" ++ showMathExprIndices (filter (not . isSub) mis) ++ ")" showMathExpr (Tuple lvs) = "(" ++ showMathExprArg lvs ++ ")" showMathExpr (Collection lvs) = "{" ++ showMathExprArg lvs ++ "}" showMathExpr' :: MathExpr -> String showMathExpr' (Plus lvs) = "(" ++ showMathExpr (Plus lvs) ++ ")" -showMathExpr' val = showMathExpr val +showMathExpr' val = showMathExpr val showMathExprArg :: [MathExpr] -> String showMathExprArg exprs = intercalate ", " $ map showMathExpr exprs diff --git a/hs-src/Language/Egison/PrettyMath/Latex.hs b/hs-src/Language/Egison/PrettyMath/Latex.hs --- a/hs-src/Language/Egison/PrettyMath/Latex.hs +++ b/hs-src/Language/Egison/PrettyMath/Latex.hs @@ -7,7 +7,7 @@ ( showMathExpr ) where -import Data.List (intercalate) +import Data.List (intercalate) import Language.Egison.PrettyMath.AST @@ -31,11 +31,11 @@ showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs where showMathExprForPlus :: [MathExpr] -> String - showMathExprForPlus [] = "" - showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs + showMathExprForPlus [] = "" + showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs - showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs - showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs + showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs + showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs showMathExpr (Multiply []) = "" showMathExpr (Multiply [x]) = showMathExpr x showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs) @@ -74,10 +74,10 @@ showMathExprScript is = "_{" ++ concatMap showMathExprSub is ++ "}^{" ++ concatMap showMathExprSuper is ++ "}" showMathExprVectors :: [MathExpr] -> String -showMathExprVectors [] = "" +showMathExprVectors [] = "" showMathExprVectors (Tensor lvs []:r) = showMathExprArg lvs " & " ++ " \\\\ " ++ showMathExprVectors r -showMathExprVectors lvs = showMathExprArg lvs " \\\\ " ++ "\\\\ " +showMathExprVectors lvs = showMathExprArg lvs " \\\\ " ++ "\\\\ " elemCount :: Eq a => [a] -> [(a, Int)] -elemCount [] = [] +elemCount [] = [] elemCount (x:xs) = (x, length (filter (== x) xs) + 1) : elemCount (filter (/= x) xs) diff --git a/hs-src/Language/Egison/PrettyMath/Mathematica.hs b/hs-src/Language/Egison/PrettyMath/Mathematica.hs --- a/hs-src/Language/Egison/PrettyMath/Mathematica.hs +++ b/hs-src/Language/Egison/PrettyMath/Mathematica.hs @@ -7,7 +7,7 @@ ( showMathExpr ) where -import Data.List (intercalate) +import Data.List (intercalate) import Language.Egison.PrettyMath.AST @@ -20,11 +20,11 @@ showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs where showMathExprForPlus :: [MathExpr] -> String - showMathExprForPlus [] = "" - showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs + showMathExprForPlus [] = "" + showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs - showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs - showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs + showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs + showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs showMathExpr (Multiply []) = "" showMathExpr (Multiply [x]) = showMathExpr x showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs) @@ -42,7 +42,7 @@ showMathExpr (Tensor lvs mis) | null mis = "{" ++ showMathExprArg lvs ++ "}" | not (any isSub mis) = "{" ++ showMathExprArg lvs ++ "}^(" ++ showMathExprIndices mis ++ ")" - | not (any (not . isSub) mis) = "{" ++ showMathExprArg lvs ++ "}_(" ++ showMathExprIndices mis ++ ")" + | all isSub mis = "{" ++ showMathExprArg lvs ++ "}_(" ++ showMathExprIndices mis ++ ")" | otherwise = "{" ++ showMathExprArg lvs ++ "}_(" ++ showMathExprIndices (filter isSub mis) ++ ")^(" ++ showMathExprIndices (filter (not . isSub) mis) ++ ")" showMathExpr (Tuple xs) = "(" ++ showMathExprArg xs ++ ")" showMathExpr (Collection xs) = "{" ++ showMathExprArg xs ++ "}" @@ -50,7 +50,7 @@ showMathExpr' :: MathExpr -> String showMathExpr' (Plus xs) = "(" ++ showMathExpr (Plus xs) ++ ")" -showMathExpr' x = showMathExpr x +showMathExpr' x = showMathExpr x showMathExprs :: String -> [MathExpr] -> String showMathExprs sep exprs = intercalate sep $ map showMathExpr exprs diff --git a/hs-src/Language/Egison/PrettyMath/Maxima.hs b/hs-src/Language/Egison/PrettyMath/Maxima.hs --- a/hs-src/Language/Egison/PrettyMath/Maxima.hs +++ b/hs-src/Language/Egison/PrettyMath/Maxima.hs @@ -17,11 +17,11 @@ showMathExpr (Plus (x:xs)) = showMathExpr x ++ showMathExprForPlus xs where showMathExprForPlus :: [MathExpr] -> String - showMathExprForPlus [] = "" - showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs + showMathExprForPlus [] = "" + showMathExprForPlus (NegativeAtom a:xs) = " - " ++ a ++ showMathExprForPlus xs showMathExprForPlus (Multiply (NegativeAtom "1":ys):xs) = " - " ++ showMathExpr (Multiply ys) ++ showMathExprForPlus xs - showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs - showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs + showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ showMathExprForPlus xs + showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs showMathExpr (Multiply []) = "" showMathExpr (Multiply [x]) = showMathExpr x showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs) @@ -43,10 +43,10 @@ showMathExpr' :: MathExpr -> String showMathExpr' x@(Plus _) = "(" ++ showMathExpr x ++ ")" -showMathExpr' x = showMathExpr x +showMathExpr' x = showMathExpr x showMathExprArg :: [MathExpr] -> String -showMathExprArg [] = "" +showMathExprArg [] = "" showMathExprArg [Tensor _ []] = "undefined" -showMathExprArg [a] = showMathExpr a -showMathExprArg lvs = showMathExpr (head lvs) ++ ", " ++ showMathExprArg (tail lvs) +showMathExprArg [a] = showMathExpr a +showMathExprArg lvs = showMathExpr (head lvs) ++ ", " ++ showMathExprArg (tail lvs) 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 @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {- | Module : Language.Egison.Primitives @@ -17,23 +16,22 @@ import Data.IORef -import qualified Data.Sequence as Sq -import qualified Data.Vector as V +import qualified Data.Sequence as Sq +import qualified Data.Vector as V {-- -- for 'egison-sqlite' import qualified Database.SQLite3 as SQLite --} -- for 'egison-sqlite' import Language.Egison.Data -import Language.Egison.Data.Collection (makeICollection) -import Language.Egison.EvalState (MonadEval(..)) -import Language.Egison.IExpr (stringToVar, Index(..)) +import Language.Egison.Data.Collection (makeICollection) +import Language.Egison.IExpr (Index (..), stringToVar) +import Language.Egison.Math import Language.Egison.Primitives.Arith import Language.Egison.Primitives.IO import Language.Egison.Primitives.String import Language.Egison.Primitives.Types import Language.Egison.Primitives.Utils -import Language.Egison.Math primitiveEnv :: IO Env primitiveEnv = do @@ -122,7 +120,7 @@ return (ScalarData (SingleSymbol (Symbol id name (is ++ [Sub s])))) (ScalarData (SingleSymbol (Symbol id name is)), ScalarData s@(SingleTerm _ [])) -> return (ScalarData (SingleSymbol (Symbol id name (is ++ [Sub s])))) - _ -> throwError =<< TypeMismatch "symbol or integer" (Value fn) <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "symbol or integer" (Value fn)) addSuperscript :: String -> PrimitiveFunc addSuperscript = twoArgs $ \fn sub -> @@ -131,21 +129,21 @@ return (ScalarData (SingleSymbol (Symbol id name (is ++ [Sup s])))) (ScalarData (SingleSymbol (Symbol id name is)), ScalarData s@(SingleTerm _ [])) -> return (ScalarData (SingleSymbol (Symbol id name (is ++ [Sup s])))) - _ -> throwError =<< TypeMismatch "symbol" (Value fn) <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "symbol" (Value fn)) assert :: String -> PrimitiveFunc assert = twoArgs' $ \label test -> do test <- fromEgison test if test then return $ Bool True - else throwError =<< Assertion (show label) <$> getFuncNameStack + else throwErrorWithTrace (Assertion (show label)) assertEqual :: String -> PrimitiveFunc assertEqual = threeArgs' $ \label actual expected -> if actual == expected then return $ Bool True - else throwError =<< Assertion - (show label ++ "\n expected: " ++ show expected ++ "\n but found: " ++ show actual) <$> getFuncNameStack + else throwErrorWithTrace (Assertion + (show label ++ "\n expected: " ++ show expected ++ "\n but found: " ++ show actual)) {-- -- for 'egison-sqlite' sqlite :: PrimitiveFunc diff --git a/hs-src/Language/Egison/Primitives/Arith.hs b/hs-src/Language/Egison/Primitives/Arith.hs --- a/hs-src/Language/Egison/Primitives/Arith.hs +++ b/hs-src/Language/Egison/Primitives/Arith.hs @@ -12,11 +12,9 @@ ( primitiveArithFunctions ) where -import Control.Monad.Except import Language.Egison.Data -import Language.Egison.EvalState (MonadEval(..)) -import Language.Egison.Primitives.Utils import Language.Egison.Math +import Language.Egison.Primitives.Utils primitiveArithFunctions :: [(String, EgisonValue)] primitiveArithFunctions = @@ -96,8 +94,8 @@ scalarBinaryOp mOp = twoArgs scalarBinaryOp' where scalarBinaryOp' (ScalarData m1) (ScalarData m2) = (return . ScalarData) (mOp m1 m2) - scalarBinaryOp' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack - scalarBinaryOp' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + scalarBinaryOp' (ScalarData _) val = throwErrorWithTrace (TypeMismatch "number" (Value val)) + scalarBinaryOp' val _ = throwErrorWithTrace (TypeMismatch "number" (Value val)) plus :: String -> PrimitiveFunc plus = scalarBinaryOp mathPlus @@ -115,19 +113,19 @@ numerator' = oneArg numerator'' where numerator'' (ScalarData m) = return $ ScalarData (mathNumerator m) - numerator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack + numerator'' val = throwErrorWithTrace (TypeMismatch "rational" (Value val)) denominator' :: String -> PrimitiveFunc denominator' = oneArg denominator'' where denominator'' (ScalarData m) = return $ ScalarData (mathDenominator m) - denominator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack + denominator'' val = throwErrorWithTrace (TypeMismatch "rational" (Value val)) fromScalarData :: String -> PrimitiveFunc fromScalarData = oneArg fromScalarData' where fromScalarData' (ScalarData m) = return $ mathExprToEgison m - fromScalarData' val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + fromScalarData' val = throwErrorWithTrace (TypeMismatch "number" (Value val)) toScalarData :: String -> PrimitiveFunc toScalarData = oneArg $ \val -> @@ -137,7 +135,7 @@ symbolNormalize = oneArg $ \val -> case val of ScalarData s -> return $ ScalarData (rewriteSymbol s) - _ -> throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "math expression" (Value val)) -- -- Pred @@ -154,14 +152,14 @@ r2 <- fromEgison val2 :: EvalM Rational return $ Bool (cmp r1 r2) (Float f1, Float f2) -> return $ Bool (cmp f1 f2) - (ScalarData _, _) -> throwError =<< TypeMismatch "number" (Value val2) <$> getFuncNameStack - (Float _, _) -> throwError =<< TypeMismatch "float" (Value val2) <$> getFuncNameStack - _ -> throwError =<< TypeMismatch "number" (Value val1) <$> getFuncNameStack + (ScalarData _, _) -> throwErrorWithTrace (TypeMismatch "number" (Value val2)) + (Float _, _) -> throwErrorWithTrace (TypeMismatch "float" (Value val2)) + _ -> throwErrorWithTrace (TypeMismatch "number" (Value val1)) truncate' :: String -> PrimitiveFunc truncate' = oneArg $ \val -> numberUnaryOp' val where - numberUnaryOp' (ScalarData (Div (Plus []) _)) = return $ toEgison (0 :: Integer) + numberUnaryOp' (ScalarData (Div (Plus []) _)) = return $ toEgison (0 :: Integer) numberUnaryOp' (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return $ toEgison (quot x y) - numberUnaryOp' (Float x) = return $ toEgison (truncate x :: Integer) - numberUnaryOp' val = throwError =<< TypeMismatch "rational or float" (Value val) <$> getFuncNameStack + numberUnaryOp' (Float x) = return $ toEgison (truncate x :: Integer) + numberUnaryOp' val = throwErrorWithTrace (TypeMismatch "rational or float" (Value val)) diff --git a/hs-src/Language/Egison/Primitives/IO.hs b/hs-src/Language/Egison/Primitives/IO.hs --- a/hs-src/Language/Egison/Primitives/IO.hs +++ b/hs-src/Language/Egison/Primitives/IO.hs @@ -22,7 +22,6 @@ import Language.Egison.Core (evalWHNF) import Language.Egison.Data -import Language.Egison.EvalState (MonadEval(..)) import Language.Egison.Primitives.Utils @@ -195,5 +194,5 @@ val <- m >>= evalWHNF case val of Tuple [_, val'] -> return $ Value val' - _ -> throwError =<< TypeMismatch "io" (Value val) <$> getFuncNameStack - io' whnf = throwError =<< TypeMismatch "io" whnf <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "io" (Value val)) + io' whnf = throwErrorWithTrace (TypeMismatch "io" whnf) diff --git a/hs-src/Language/Egison/Primitives/String.hs b/hs-src/Language/Egison/Primitives/String.hs --- a/hs-src/Language/Egison/Primitives/String.hs +++ b/hs-src/Language/Egison/Primitives/String.hs @@ -55,7 +55,7 @@ str <- fromEgison val case T.uncons str of Just (c, rest) -> return $ Tuple [Char c, String rest] - Nothing -> throwError $ Default "Tried to unsnoc empty string" + Nothing -> throwError $ Default "Tried to unsnoc empty string" lengthString :: String -> PrimitiveFunc lengthString = unaryOp (toInteger . T.length) @@ -74,7 +74,7 @@ patStr <- fromEgison pat srcStr <- fromEgison src case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe (String, String, String)) of - Nothing -> return . Collection . Sq.fromList $ [] + Nothing -> return . Collection . Sq.fromList $ [] Just (a,b,c) -> return . Collection . Sq.fromList $ [Tuple [String (T.pack a), String (T.pack b), String (T.pack c)]] regexStringCaptureGroup :: String -> PrimitiveFunc diff --git a/hs-src/Language/Egison/Primitives/Types.hs b/hs-src/Language/Egison/Primitives/Types.hs --- a/hs-src/Language/Egison/Primitives/Types.hs +++ b/hs-src/Language/Egison/Primitives/Types.hs @@ -10,13 +10,10 @@ ( primitiveTypeFunctions ) where -import Control.Monad.Except - import Data.Char (chr, ord) import Data.Ratio ((%)) import Language.Egison.Data -import Language.Egison.EvalState (MonadEval(..)) import Language.Egison.Math import Language.Egison.Primitives.Utils @@ -109,9 +106,9 @@ rationalToFloat :: String -> PrimitiveFunc rationalToFloat = oneArg $ \val -> case val of - ScalarData (Div (Plus []) _) -> return $ Float 0 + ScalarData (Div (Plus []) _) -> return $ Float 0 ScalarData (Div (Plus [Term x []]) (Plus [Term y []])) -> return $ Float (fromRational (x % y)) - _ -> throwError =<< TypeMismatch "integer or rational number" (Value val) <$> getFuncNameStack + _ -> throwErrorWithTrace (TypeMismatch "integer or rational number" (Value val)) charToInteger :: String -> PrimitiveFunc charToInteger = unaryOp ctoi diff --git a/hs-src/Language/Egison/Primitives/Utils.hs b/hs-src/Language/Egison/Primitives/Utils.hs --- a/hs-src/Language/Egison/Primitives/Utils.hs +++ b/hs-src/Language/Egison/Primitives/Utils.hs @@ -15,12 +15,9 @@ , binaryOp ) where -import Control.Monad.Except - -import qualified Data.Vector as V +import qualified Data.Vector as V import Language.Egison.Data -import Language.Egison.EvalState (MonadEval(..)) import Language.Egison.Tensor {-# INLINE noArg #-} @@ -30,7 +27,7 @@ [] -> f [Tuple []] -> f _ -> - throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack + throwErrorWithTrace (ArgumentsNumPrimitive name 1 (length args)) {-# INLINE oneArg #-} oneArg :: (EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc @@ -41,22 +38,22 @@ return $ TensorData (Tensor ns ds' js) [arg] -> f arg _ -> - throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack + throwErrorWithTrace (ArgumentsNumPrimitive name 1 (length args)) {-# INLINE oneArg' #-} oneArg' :: (EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc oneArg' f name args = case args of [arg] -> f arg - _ -> - throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack + _ -> + throwErrorWithTrace (ArgumentsNumPrimitive name 1 (length args)) {-# INLINE twoArgs #-} twoArgs :: (EgisonValue -> EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc twoArgs f name args = case args of [TensorData t1@Tensor{}, TensorData t2@Tensor{}] -> - tProduct (\x y -> f x y) t1 t2 >>= fromTensor + tProduct f t1 t2 >>= fromTensor [TensorData(Tensor ns ds js), val] -> do ds' <- V.mapM (`f` val) ds return $ TensorData (Tensor ns ds' js) @@ -65,7 +62,7 @@ return $ TensorData (Tensor ns ds' js) [val, val'] -> f val val' [val] -> return . PrimitiveFunc $ oneArg (f val) name - _ -> throwError =<< ArgumentsNumPrimitive name 2 (length args) <$> getFuncNameStack + _ -> throwErrorWithTrace (ArgumentsNumPrimitive name 2 (length args)) {-# INLINE twoArgs' #-} twoArgs' :: (EgisonValue -> EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc @@ -73,7 +70,7 @@ case args of [val, val'] -> f val val' [val] -> return . PrimitiveFunc $ oneArg' (f val) name - _ -> throwError =<< ArgumentsNumPrimitive name 2 (length args) <$> getFuncNameStack + _ -> throwErrorWithTrace (ArgumentsNumPrimitive name 2 (length args)) {-# INLINE threeArgs' #-} threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc @@ -82,13 +79,13 @@ [val, val', val''] -> f val val' val'' [val, val'] -> return . PrimitiveFunc $ oneArg' (f val val') name [val] -> return . PrimitiveFunc $ twoArgs' (f val) name - _ -> throwError =<< ArgumentsNumPrimitive name 3 (length args) <$> getFuncNameStack + _ -> throwErrorWithTrace (ArgumentsNumPrimitive name 3 (length args)) lazyOneArg :: (WHNFData -> EvalM WHNFData) -> String -> LazyPrimitiveFunc lazyOneArg f name args = case args of [arg] -> f arg - _ -> throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack + _ -> throwErrorWithTrace (ArgumentsNumPrimitive name 1 (length args)) unaryOp :: (EgisonData a, EgisonData b) => (a -> b) -> String -> PrimitiveFunc unaryOp op = oneArg $ \val -> do diff --git a/hs-src/Language/Egison/RState.hs b/hs-src/Language/Egison/RState.hs --- a/hs-src/Language/Egison/RState.hs +++ b/hs-src/Language/Egison/RState.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} {- | Module : Language.Egison.RState @@ -30,8 +29,8 @@ data RState = RState { indexCounter :: Int - , exprOps :: [Op] - , patternOps :: [Op] + , exprOps :: [Op] + , patternOps :: [Op] } initialRState :: RState diff --git a/hs-src/Language/Egison/Tensor.hs b/hs-src/Language/Egison/Tensor.hs --- a/hs-src/Language/Egison/Tensor.hs +++ b/hs-src/Language/Egison/Tensor.hs @@ -1,8 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ViewPatterns #-} {- | @@ -17,7 +16,6 @@ -- * Tensor , tref , enumTensorIndices - , changeIndex , tTranspose , tTranspose' , tFlipIndices @@ -31,19 +29,18 @@ , tConcat' ) where -import Prelude hiding (foldr, mappend, mconcat) +import Prelude hiding (foldr, mappend, mconcat) -import Control.Monad.Except hiding (join) -import qualified Data.Vector as V -import Data.List (delete, intersect, partition, (\\)) +import Control.Monad.Except (mzero, throwError, zipWithM) +import Data.List (delete, intersect, partition, (\\)) +import qualified Data.Vector as V import Control.Egison -import qualified Control.Egison as M +import qualified Control.Egison as M import Language.Egison.Data import Language.Egison.Data.Utils -import Language.Egison.EvalState (getFuncNameStack) -import Language.Egison.IExpr (Index(..), extractSupOrSubIndex) +import Language.Egison.IExpr (Index (..), extractSupOrSubIndex) import Language.Egison.Math import Language.Egison.RState @@ -105,26 +102,26 @@ tIntRef' i (Tensor [n] xs _) = if 0 < i && i <= n then return . Scalar $ xs V.! fromIntegral (i - 1) - else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack + else throwErrorWithTrace (TensorIndexOutOfBounds i n) tIntRef' i (Tensor (n:ns) xs js) = if 0 < i && i <= n then let w = fromIntegral (product ns) ys = V.take w (V.drop (w * fromIntegral (i - 1)) xs) in return $ Tensor ns ys (cdr js) - else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack + else throwErrorWithTrace (TensorIndexOutOfBounds i n) tIntRef' _ _ = throwError $ Default "More indices than the order of the tensor" tIntRef :: [Integer] -> Tensor a -> EvalM (Tensor a) tIntRef [] (Tensor [] xs _) | V.length xs == 1 = return $ Scalar (xs V.! 0) - | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack + | otherwise = throwErrorWithTrace (EgisonBug "sevaral elements in scalar tensor") tIntRef [] t = return t tIntRef (m:ms) t = tIntRef' m t >>= tIntRef ms tIntRef1 :: [Integer] -> Tensor a -> EvalM a tIntRef1 [] (Scalar x) = return x tIntRef1 [] (Tensor [] xs _) | V.length xs == 1 = return (xs V.! 0) -tIntRef1 [] _ = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack +tIntRef1 [] _ = throwErrorWithTrace (EgisonBug "sevaral elements in scalar tensor") tIntRef1 (m:ms) t = tIntRef' m t >>= tIntRef1 ms pattern SupOrSubIndex :: a -> Index a @@ -133,7 +130,7 @@ tref :: [Index EgisonValue] -> Tensor a -> EvalM (Tensor a) tref [] (Tensor [] xs _) | V.length xs == 1 = return $ Scalar (xs V.! 0) - | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack + | otherwise = throwErrorWithTrace (EgisonBug "sevaral elements in scalar tensor") tref [] t = return t tref (s@(SupOrSubIndex (ScalarData (SingleSymbol _))):ms) (Tensor (_:ns) xs js) = do let yss = split (product ns) xs @@ -162,13 +159,9 @@ -- >>> enumTensorIndices [2,2,2] -- [[1,1,1],[1,1,2],[1,2,1],[1,2,2],[2,1,1],[2,1,2],[2,2,1],[2,2,2]] enumTensorIndices :: Shape -> [[Integer]] -enumTensorIndices [] = [[]] +enumTensorIndices [] = [[]] enumTensorIndices (n:ns) = concatMap (\i -> map (i:) (enumTensorIndices ns)) [1..n] -changeIndex :: Index String -> EgisonValue -> Index String -changeIndex (Sup s) m = Sup (s ++ show m) -changeIndex (Sub s) m = Sub (s ++ show m) - -- transIndex [a, b, c] [c, a, b] [2, 3, 4] = [4, 2, 3] transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> Shape -> EvalM Shape transIndex is js ns = do @@ -184,13 +177,13 @@ let js' = take (length is) js let ds = complementWithDF ns is ns' <- transIndex (js' ++ ds) (is ++ ds) ns - xs' <- V.fromList <$> mapM (transIndex (is ++ ds) (js' ++ ds)) (enumTensorIndices ns') >>= mapM (`tIntRef1` t) + xs' <- mapM (transIndex (is ++ ds) (js' ++ ds)) (enumTensorIndices ns') >>= mapM (`tIntRef1` t) . V.fromList return $ Tensor ns' xs' is tTranspose' :: [EgisonValue] -> Tensor a -> EvalM (Tensor a) tTranspose' is t@(Tensor _ _ js) = case mapM (\i -> f i js) is of - Nothing -> return t + Nothing -> return t Just is' -> tTranspose is' t where f :: EgisonValue -> [Index EgisonValue] -> Maybe (Index EgisonValue) diff --git a/hs-src/Tool/translator.hs b/hs-src/Tool/translator.hs --- a/hs-src/Tool/translator.hs +++ b/hs-src/Tool/translator.hs @@ -62,10 +62,10 @@ toNonS :: a -> a instance SyntaxElement TopExpr where - toNonS (Define x y) = Define (toNonS x) (toNonS y) - toNonS (Test x) = Test (toNonS x) - toNonS (Execute x) = Execute (toNonS x) - toNonS x = x + toNonS (Define x y) = Define (toNonS x) (toNonS y) + toNonS (Test x) = Test (toNonS x) + toNonS (Execute x) = Execute (toNonS x) + toNonS x = x instance SyntaxElement Expr where toNonS (VarExpr (lookupVarExprInfix -> Just op)) = @@ -176,15 +176,15 @@ instance SyntaxElement PrimitivePatPattern where toNonS (PPInductivePat x pps) = PPInductivePat x (map toNonS pps) - toNonS (PPTuplePat pps) = PPTuplePat (map toNonS pps) - toNonS pp = pp + toNonS (PPTuplePat pps) = PPTuplePat (map toNonS pps) + toNonS pp = pp instance SyntaxElement PrimitiveDataPattern where toNonS (PDInductivePat x pds) = PDInductivePat x (map toNonS pds) - toNonS (PDTuplePat pds) = PDTuplePat (map toNonS pds) - toNonS (PDConsPat pd1 pd2) = PDConsPat (toNonS pd1) (toNonS pd2) - toNonS (PDSnocPat pd1 pd2) = PDSnocPat (toNonS pd1) (toNonS pd2) - toNonS pd = pd + toNonS (PDTuplePat pds) = PDTuplePat (map toNonS pds) + toNonS (PDConsPat pd1 pd2) = PDConsPat (toNonS pd1) (toNonS pd2) + toNonS (PDSnocPat pd1 pd2) = PDSnocPat (toNonS pd1) (toNonS pd2) + toNonS pd = pd instance SyntaxElement LoopRange where toNonS (LoopRange e1 e2 p) = LoopRange (toNonS e1) (toNonS e2) (toNonS p) @@ -193,7 +193,7 @@ toNonS script = toNonS <$> script instance SyntaxElement BindingExpr where - toNonS (Bind pdp x) = Bind (toNonS pdp) (toNonS x) + toNonS (Bind pdp x) = Bind (toNonS pdp) (toNonS x) toNonS (BindWithIndices var x) = BindWithIndices var (toNonS x) instance SyntaxElement MatchClause where diff --git a/lib/core/assoc.egi b/lib/core/assoc.egi --- a/lib/core/assoc.egi +++ b/lib/core/assoc.egi @@ -17,36 +17,6 @@ | ($x, $n) :: $rs -> take n (repeat1 x) ++ fromAssoc rs -- --- Assoc List --- -def assocList a := - matcher - | [] as () with - | [] -> [()] - | _ -> [] - | $ :: $ as (a, assocList a) with - | $tgt -> - match tgt as list (something, integer) with - | ($x, #1) :: $rs -> [(x, rs)] - | ($x, $n) :: $rs -> [(x, (x, n - 1) :: rs)] - | _ -> [] - | ncons $ #$k $ as (a, assocList a) with - | $tgt -> - match tgt as list (something, integer) with - | ($x, #k) :: $rs -> [(x, rs)] - | ($x, ?(> k) & $n) :: $rs -> [(x, (x, n - k) :: rs)] - | _ -> [] - | ncons $ $ $ as (a, integer, assocList a) with - | $tgt -> - match tgt as list (something, integer) with - | ($x, $k) :: $rs -> [(x, k, rs)] - | _ -> [] - | #$val as () with - | $tgt -> if val = tgt then [()] else [] - | $ as (something) with - | $tgt -> [tgt] - --- -- Assoc Multiset -- def assocMultiset a := @@ -54,41 +24,41 @@ | [] as () with | [] -> [()] | _ -> [] - | #$x :: $ as (assocMultiset a) with - | $tgt -> - matchAll tgt as list (a, integer) with - | $hs ++ (#x, $n) :: $ts -> - if n = 1 then hs ++ ts else hs ++ (x, n - 1) :: ts - | $ :: $ as (a, assocMultiset a) with - | $tgt -> - matchAll tgt as list (a, integer) with - | $hs ++ ($x, $n) :: $ts -> - if n = 1 then (x, hs ++ ts) else (x, hs ++ (x, n - 1) :: ts) - | ncons #$x #$n $ as (assocMultiset a) with + | #$x ^ #$n :: $ as (assocMultiset a) with | $tgt -> matchAll tgt as list (a, integer) with | $hs ++ (#x, ?(>= n) & $k) :: $ts -> if k - n = 0 then hs ++ ts else hs ++ (x, k - n) :: ts - | ncons $ #$n $ as (a, assocMultiset a) with + | $ ^ #$n :: $ as (a, assocMultiset a) with | $tgt -> matchAll tgt as list (a, integer) with | $hs ++ ($x, ?(>= n) & $k) :: $ts -> if k - n = 0 then (x, hs ++ ts) else (x, hs ++ (x, k - n) :: ts) - | ncons #$x $ $ as (integer, assocMultiset a) with + | #$x ^ $ :: $ as (integer, assocMultiset a) with | $tgt -> matchAll tgt as list (a, integer) with | $hs ++ (#x, $n) :: $ts -> (n, hs ++ ts) - | ncons $ $ $ as (a, integer, assocMultiset a) with + | $ ^ $ :: $ as (a, integer, assocMultiset a) with | $tgt -> matchAll tgt as list (a, integer) with | $hs ++ ($x, $n) :: $ts -> (x, n, hs ++ ts) + | #$x :: $ as (assocMultiset a) with + | $tgt -> + matchAll tgt as list (a, integer) with + | $hs ++ (#x, $n) :: $ts -> + if n = 1 then hs ++ ts else hs ++ (x, n - 1) :: ts + | $ :: $ as (a, assocMultiset a) with + | $tgt -> + matchAll tgt as list (a, integer) with + | $hs ++ ($x, $n) :: $ts -> + if n = 1 then (x, hs ++ ts) else (x, hs ++ (x, n - 1) :: ts) | $ as (something) with | $tgt -> [tgt] def AC.intersect xs ys := matchAll (xs, ys) as (assocMultiset something, assocMultiset something) with - | (ncons $x $m _, ncons #x $n _) -> (x, min m n) + | ($x ^ $m :: _, #x ^ $n :: _) -> (x, min m n) def AC.intersectAs a xs ys := matchAll (xs, ys) as (assocMultiset a, assocMultiset a) with - | (ncons $x $m _, ncons #x $n _) -> (x, min m n) + | ($x ^ $m :: _, #x ^ $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 @@ -22,8 +22,8 @@ def id := 1#%1 -def fst (x, y) := x -def snd (x, y) := y +def fst (x, _) := x +def snd (_, y) := y infixr expression 0 $ diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -4,6 +4,8 @@ -- -- +infixr pattern 5 ++ + -- -- List -- @@ -148,7 +150,7 @@ | [] -> True | _ -> False -def length xs := foldl 2#(%1 + 1) 0 xs +def length xs := foldl (\acc _ -> acc + 1) 0 xs def map fn xs := match xs as list something with diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -120,7 +120,7 @@ in (q, map fst s, map fst c) def showDecimal c x := - match (\(x, y) -> (x, take c y)) (rtod x) as (integer, list integer) with + match (2)#(%1, take c %2) (rtod x) as (integer, list integer) with | ($q, $sc) -> foldl S.append (S.append (show q) ".") (map show sc) def showDecimal' x := @@ -158,7 +158,7 @@ in if x = 0 then (n, []) else ( n - , map (\(_, _, z) -> z) (regularContinuedFractionOfSqrtHelper m (n / x) (1 / x)) ) + , map (3)#%3 (regularContinuedFractionOfSqrtHelper m (n / x) (1 / x)) ) def regularContinuedFractionOfSqrt' m := let n := floor (sqrt (rtof m)) @@ -170,6 +170,6 @@ m (n / x) (1 / x)) - in (n, map (\(_, _, x) -> x) s, map (\(_, _, x) -> x) c) + in (n, map (3)#%3 s, map (3)#%3 c) def pi := f.pi diff --git a/lib/core/order.egi b/lib/core/order.egi --- a/lib/core/order.egi +++ b/lib/core/order.egi @@ -26,8 +26,8 @@ def min $x $y := if x < y then x else y def max $x $y := if x > y then x else y -def min/fn f $xs := foldl1 2#(if f %1 %2 = Less then %1 else %2) xs -def max/fn f $xs := foldl1 2#(if f %1 %2 = Greater then %1 else %2) xs +def min/fn f $xs := foldl1 (\x y -> if f x y = Less then x else y) xs +def max/fn f $xs := foldl1 (\x y -> if f x y = Greater then x else y) xs def minimum $xs := foldl1 min xs def maximum $xs := foldl1 max xs @@ -57,7 +57,7 @@ in sort/fn f ys1 ++ ys2 ++ sort/fn f ys3 def sortStrings xs := - sort/fn 2#(compareC (map ctoi (unpack %1)) (map ctoi (unpack %2))) xs + sort/fn (\x y -> compareC (map ctoi (unpack x)) (map ctoi (unpack y))) xs def merge xs ys := match (xs, ys) as (list something, list something) with @@ -74,7 +74,7 @@ | (_, $y :: $tys) -> y :: merge xs tys def minimize f xs := - foldl1 2#(if compare (f %1) (f %2) = Less then %1 else %2) xs + foldl1 (\x y -> if compare (f x) (f y) = Less then x else y) xs def maximize f xs := - foldl1 2#(if compare (f %1) (f %2) = Greater then %1 else %2) xs + foldl1 (\x y -> if compare (f x) (f y) = Greater then x else y) xs diff --git a/lib/core/shell.egi b/lib/core/shell.egi --- a/lib/core/shell.egi +++ b/lib/core/shell.egi @@ -1,25 +1,16 @@ +-- Get input and parse them into the format specified with sopts and copts. +-- Used in --map and --filter options. def SH.genInput sopts copts := - if io $ isEof () - then [] - else let line := io $ readLine () - x := TSV.parseLine sopts copts line - in seq x (x :: SH.genInput sopts copts) - -def TSV.map fn showFn := do - let eof := isEof () - if eof - then return () - else do let line := readLine () - print (showFn (fn (readTsv line))) - TSV.map fn showFn - -def TSV.filter fn := do - let eof := isEof () - if eof - then return () - else do let line := readLine () - if fn (readTsv line) then print line else return () - TSV.filter fn + map (TSV.parseLine sopts copts) (io (readLines ())) + where + -- Read multiple lines from stdin until EOF. + readLines () := do + let eof := isEof () + if eof + then return [] + else do let line := readLine () + let lines := readLines () + return (line :: lines) def TSV.parseLine sopts copts line := readTsv (S.intercalate "\t" (fnC copts (fnS sopts (S.split "\t" line)))) @@ -33,7 +24,7 @@ let (hs, ts') := splitAt (m - 1) xs (mf, ts) := uncons ts' in fnS opts' (hs ++ S.concat ["\"", mf, "\""] :: ts) - | [$m, $n] :: $opts' -> + | [$m, $n & ?(> m)] :: $opts' -> let (hs, ts') := splitAt (m - 1) xs (ms, ts) := splitAt (n - m + 1) ts' in fnS opts' (hs ++ map (\m -> S.concat ["\"", m, "\""]) ms ++ ts) @@ -48,7 +39,7 @@ let (hs, ts') := splitAt (m - 1) xs (mf, ts) := uncons ts' in fnC opts' (hs ++ S.concat ["[", mf, "]"] :: ts) - | [$m, $n] :: $opts' -> + | [$m, $n & ?(> m)] :: $opts' -> let (hs, ts') := splitAt (m - 1) xs (ms, ts) := splitAt (n - m + 1) ts' in fnC opts' (hs ++ S.concat ["[", S.intercalate ", " ms, "]"] :: ts) diff --git a/lib/core/sort.egi b/lib/core/sort.egi --- a/lib/core/sort.egi +++ b/lib/core/sort.egi @@ -15,17 +15,18 @@ | [$x] -> (1, x) | [$x, $y] -> if compare x y = Greater then (-1, y ++ x) else (1, x ++ y) - | _ -> io $ - do let t := return (colToTensor xs) - let n := return (length xs) - let sgn := sort' 1 2 n t 1 - let xs' := return (map (\i -> io $ readIORef t_i) [1..n]) - return (sgn, concat xs') + | _ -> + io (do let t := return (colToTensor xs) + let n := return (length xs) + let sgn := sort' 1 2 n t 1 + let xs' := return (map (\i -> io $ readIORef t_i) [1..n]) + return (sgn, concat xs')) where colToTensor xs := - generateTensor (\n -> io $ do let t := newIORef () - writeIORef t (nth n xs) - return t) [length xs] + generateTensor (\[n] -> io $ + do let t := newIORef () + writeIORef t (nth n xs) + return t) [length xs] sort' i j n ts sgn := if i = n 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 @@ -23,7 +23,7 @@ def qF f x := match coefficients f x as list mathExpr with - | $a_0 :: $a_1 :: $a_2 :: [] -> qF' a_2 a_1 a_0 + | [$a_0, $a_1, $a_2] -> qF' a_2 a_1 a_0 def qF' a b c := ( ((- b) + sqrt (b ^ 2 - 4 * a * c)) / 2 * a @@ -41,7 +41,7 @@ def cF' a b c d := match (a, b, c, d) as (mathExpr, mathExpr, mathExpr, mathExpr) with | (#1, #0, $p, $q) -> - let (s1, s2) := (\(x, y) -> (rt 3 x, rt 3 y)) (qF' 1 (27 * q) ((-27) * p ^ 3)) + let (s1, s2) := (2)#(rt 3 %1, rt 3 %2) (qF' 1 (27 * q) ((-27) * p ^ 3)) in ( (s1 + s2) / 3 -- r1 , (w ^ 2 * s1 + w * s2) / 3 -- r2 , (w * s1 + w ^ 2 * s2) / 3) -- r3 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 @@ -17,18 +17,18 @@ | _ -> inverse' t f x -- TODO: define inverse' | ?isTerm -> match f as termExpr with - | term #1 (ncons $n #x []) -> rt n t - | term _ (ncons $n #x _) -> + | term #1 ($n ^ #x :: []) -> rt n t + | term _ ($n ^ #x :: _) -> let a := f / x ^ n in inverse (t / a) (f / a) x - | _ -> `inverse t f x + | _ -> 'inverse t f x | ?isPolynomial -> match coefficients x f as list mathExpr with | $c :: (loop $i (1, $n) (#0 :: ...) ($a :: [])) -> inverse ((t - c) / a) (x ^ (n + 1)) x - | _ -> `inverse t f x + | _ -> 'inverse t f x | _ -> match f as mathExpr with | $p1 / $p2 -> inverse (p2 * t) p1 x - | _ -> `inverse t f x + | _ -> 'inverse t f x diff --git a/lib/math/algebra/matrix.egi b/lib/math/algebra/matrix.egi --- a/lib/math/algebra/matrix.egi +++ b/lib/math/algebra/matrix.egi @@ -13,9 +13,10 @@ def M.inverse %m := let d := M.det m in generateTensor - 2#(match m as matrix with - | cons #%2 #%1 _ $A $B $C $D -> - if isEven (%1 + %2) + (\[i, j] -> + match m as matrix with + | cons #j #i _ $A $B $C $D -> + if isEven (i + j) then M.det (M.join A B C D) / d else - (M.det (M.join A B C D) / d)) (tensorShape m) @@ -63,11 +64,11 @@ n1 := max c1 d1 n2 := max b2 d2 in generateTensor - 2#(match (%1, %2) as (integer, integer) with - | (?(<= a1), ?(<= a2)) -> A_%1_%2 - | (?(<= m1), _) -> B_%1_(%2 - a2) - | (_, ?(<= m2)) -> C_(%1 - a1)_%2 - | (_, _) -> D_(%1 - m1)_(%2 - m2)) + (\match as list integer with + | [$i & ?(<= a1), $j & ?(<= a2)] -> A_i_j + | [$i & ?(<= m1), $j] -> B_i_(j - a2) + | [$i, $j & ?(<= m2)] -> C_(i - a1)_j + | [$i, $j] -> D_(i - m1)_(j - m2)) [m1 + n1, m2 + n2] -- @@ -140,15 +141,15 @@ match tensorShape x as list integer with | [#2, #2] -> let L := generateTensor - 2#(match compare %1 %2 as ordering with + (\[i, j] -> match compare i j as ordering with | less -> 0 | equal -> 1 - | greater -> b_%1_%2) + | greater -> b_i_j) [2, 2] U := generateTensor - 2#(match compare %1 %2 as ordering with + (\[i, j] -> match compare i j as ordering with | greater -> 0 - | _ -> c_%1_%2) + | _ -> c_i_j) [2, 2] m := M.* L U ret := solve @@ -159,15 +160,15 @@ in (substitute ret L, substitute ret U) | [#3, #3] -> let L := generateTensor - 2#(match compare %1 %2 as ordering with + (\[i, j] -> match compare i j as ordering with | less -> 0 | equal -> 1 - | greater -> b_%1_%2) + | greater -> b_i_j) [3, 3] U := generateTensor - 2#(match compare %1 %2 as ordering with + (\[i, j] -> match compare i j as ordering with | greater -> 0 - | _ -> c_%1_%2) + | _ -> c_i_j) [3, 3] m := M.* L U ret := solve @@ -188,5 +189,5 @@ -- def generateMatrixFromQuadraticExpr f xs := generateTensor - 2#(coefficient2 f (nth %1 xs) (nth %2 xs)) + (\[i, j] -> coefficient2 f (nth i xs) (nth j xs)) [length xs, length xs] 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 @@ -44,7 +44,7 @@ let f xs := match xs as assocMultiset mathExpr with | [] -> (1, 1) - | ncons $p $k $rs -> + | $p ^ $k :: $rs -> let (a, b) := f rs in (p ^' quotient k n *' a, p ^' (k % n) *' b) g n x := @@ -60,8 +60,8 @@ def rt'' n x := match (n, x) as (integer, integer) with - | (#2, _) -> `sqrt x - | (_, _) -> `rt n x + | (#2, _) -> 'sqrt x + | (_, _) -> 'rt n x def sqrt x := if isScalar x @@ -79,5 +79,5 @@ | #2 -> -1 | #3 -> w | #4 -> i - | _ -> `rtu n - else `rtu n + | _ -> 'rtu n + else '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 @@ -13,8 +13,8 @@ def scalarToTensor x ns := x * unitTensor ns -def zeroTensor ns := generateTensor (\xs -> 0) ns +def zeroTensor ns := generateTensor (\_ -> 0) ns -def (.') %t1 %t2 := sum' (contract (t1 *' t2)) +def (.') %t1 %t2 := foldr (+') 0 (contract (t1 *' t2)) -def (.) %t1 %t2 := sum (contract (t1 * t2)) +def (.) %t1 %t2 := foldr (+) 0 (contract (t1 * t2)) 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 @@ -10,25 +10,25 @@ | #x -> 1 | ?isSymbol -> 0 -- function expression - | func _ $argnames $args _ -> + | func _ $argnames $args -> sum (map2 (\s r -> (userRefs f [s]) * ∂/∂ r x) argnames args) -- function application - | #`exp $g -> exp g * ∂/∂ g x - | #`log $g -> 1 / g * ∂/∂ g x - | #`sqrt $g -> 1 / (2 * sqrt g) * ∂/∂ g x - | #`(^) $g $h -> f * ∂/∂ (log g * h) x - | #`cos $g -> (- sin g) * ∂/∂ g x - | #`sin $g -> cos g * ∂/∂ g x - | #`arccos $g -> 1 / sqrt (1 - g ^ 2) * ∂/∂ g x + | #'exp $g -> exp g * ∂/∂ g x + | #'log $g -> 1 / g * ∂/∂ g x + | #'sqrt $g -> 1 / (2 * sqrt g) * ∂/∂ g x + | #'(^) $g $h -> f * ∂/∂ (log g * h) x + | #'cos $g -> (- sin g) * ∂/∂ g x + | #'sin $g -> cos g * ∂/∂ g x + | #'arccos $g -> 1 / sqrt (1 - g ^ 2) * ∂/∂ g x | apply $g $args -> - sum (map2 2#((capply `(userRefs g [%1]) args) * ∂/∂ %2 x) nats args) + sum (map2 (\nat arg -> (capply '(userRefs g [nat]) args) * ∂/∂ arg x) nats args) -- quote | quote $g -> let g' := ∂/∂ g x in if isMonomial g' then g' else let d := capply gcd (fromPoly g') - in d *' '(mapPoly (/' d) g') + in d *' `(mapPoly (/' d) g') -- term (constant) | #0 -> 0 | _ * #1 -> 0 @@ -55,11 +55,11 @@ def taylorExpansion $f $x $a := multivariateTaylorExpansion f [|x|] [|a|] -def maclaurinExpansion := 2#(taylorExpansion %1 %2 0) +def maclaurinExpansion f x := taylorExpansion f x 0 def multivariateTaylorExpansion $f %xs %ys := withSymbols [h] - let hs := generateTensor 1#h_%1 (tensorShape xs) + let hs := generateTensor (\[x] -> h_x) (tensorShape xs) in map2 (*) (map 1#(1 / fact %1) nats0) 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 @@ -17,20 +17,20 @@ | #(^) $a #x -> a ^ x / log a | #(^) $a $y -> withSymbols [t] substitute [(t, y)] (Sd t (a ^ t * d/d (inverse t y x) t)) - | #Sd $y $g -> `Sd x (`Sd y g) + | #Sd $y $g -> 'Sd x ('Sd y g) | $f $y -> withSymbols [t] substitute [(t, y)] (Sd t (f t * d/d (inverse t y x) t)) -- term (constant) | #0 -> 0 | term $c [] -> c * x -- term (multiplication) - | mult $a (ncons $n #x $r) -> - if containSymbol x r then `Sd x f else a / (n + 1) * x ^ (n + 1) * r + | mult $a ($n ^ #x :: $r) -> + if containSymbol x r then 'Sd x f else a / (n + 1) * x ^ (n + 1) * r -- polynomial | poly $ts -> sum (map 1#(Sd x %1) ts) -- quotient | plus $ts / $p2 -> sum (map 1#(Sd x (%1 / p2)) ts) - | $p1 / $p2 -> if containSymbol x p2 then `Sd x f else Sd x p1 / p2 + | $p1 / $p2 -> if containSymbol x p2 then 'Sd x f else Sd x p1 / p2 def multSd x f g := let F := Sd x 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 @@ -65,25 +65,25 @@ then exp n else if isRational n then if n >= 0 - then if isInteger n then power x n else `(^) x n + then if isInteger n then power x n else '(^) x n else 1 / x ^ neg n - else `(^) x n + else '(^) x n def (^') $x $n := if x = e then exp n else if isRational n then if n >= 0 - then if isInteger n then power' x n else `(^) x n + then if isInteger n then power' x n else '(^) x n else 1 /' x ^' neg n - else `(^) x n + else '(^) x n def gcd $x $y := match (x, y) as (termExpr, termExpr) with | (_, #0) -> x | (#0, _) -> y | (term $a $xs, term $b $ys) -> - gcd' (abs a) (abs b) *' foldl (*') 1 (map (^') (AC.intersect xs ys)) + gcd' (abs a) (abs b) *' foldl (*') 1 (map (\(s, n) -> s ^' n) (AC.intersect xs ys)) def gcd' $x $y := match (x, y) as (integer, integer) with @@ -96,5 +96,5 @@ let xs := reverse (coefficients fx x) ys := reverse (coefficients gx x) (zs, rs) := L./ xs ys - in ( sum' (map2 2#(%1 *' x ^' %2) (reverse zs) nats0) - , sum' (map2 2#(%1 *' x ^' %2) (reverse rs) nats0) ) + in ( sum' (map2 (\c n -> c *' x ^' n) (reverse zs) nats0) + , sum' (map2 (\c n -> c *' x ^' n) (reverse rs) nats0) ) 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 @@ -14,8 +14,8 @@ | #0 -> 1 | #1 -> e | mult $a #(i * π) -> (-1) ^ a - | _ -> `exp x - else `exp x + | _ -> 'exp x + else 'exp x def log $x := if isFloat x @@ -23,7 +23,7 @@ else match x as mathExpr with | #1 -> 0 | #e -> 1 - | _ -> `log x + | _ -> 'log x def cos $x := if isFloat x @@ -32,7 +32,7 @@ | #0 -> 1 | term $n [#π] -> (-1) ^ abs n | (mult _ #π) / #2 -> 0 - | _ -> `cos x + | _ -> 'cos x def sin $x := if isFloat x @@ -41,14 +41,14 @@ | #0 -> 0 | mult _ #π -> 0 | (mult $n #π) / #2 -> (-1) ^ ((abs n - 1) / 2) - | _ -> `sin x + | _ -> 'sin x def tan $x := if isFloat x then b.tan x else match x as mathExpr with | #0 -> 0 - | _ -> `tan x + | _ -> 'tan x def acos := b.acos def asin := b.asin @@ -59,21 +59,21 @@ then b.cosh x else match x as mathExpr with | #0 -> 1 - | _ -> `cosh x + | _ -> 'cosh x def sinh $x := if isFloat x then b.sinh x else match x as mathExpr with | #0 -> 0 - | _ -> `sinh x + | _ -> 'sinh x def tanh $x := if isFloat x then b.tanh x else match x as mathExpr with | #0 -> 0 - | _ -> `tanh x + | _ -> 'tanh x def acosh := b.acosh def asinh := b.asinh @@ -88,7 +88,7 @@ def sigmoid $z := 1 / (1 + exp (- z)) -def kroneckerDelta := cambda js -> if all (= head js) (tail js) then 1 else 0 +def kroneckerDelta js := if all (= head js) (tail js) then 1 else 0 def eulerTotientFunction $n := n * product (map (\p -> 1 - 1 / p) (unique (pF n))) @@ -96,17 +96,15 @@ memoizedLambda n -> let (es, os) := evenAndOddPermutations' n in generateTensor - (cambda is -> - if member is es then 1 else if member is os then -1 else 0) + (\is -> if member is es then 1 else if member is os then -1 else 0) (take n (repeat1 n)) def ε' := memoizedLambda n k -> let (es, os) := evenAndOddPermutations' n in generateTensor - (cambda is -> + (\is -> match drop k is as list integer with | _ ++ $x :: _ ++ ?(< x) :: _ -> 0 - | _ -> - if member is es then 1 else if member is os then -1 else 0) + | _ -> if member is es then 1 else if member is os then -1 else 0) (take n (repeat1 n)) diff --git a/lib/math/expression.egi b/lib/math/expression.egi --- a/lib/math/expression.egi +++ b/lib/math/expression.egi @@ -18,6 +18,9 @@ def mathExpr' := matcher + | div $ $ as (mathExpr, mathExpr) with + | Div $p1 $p2 -> [(toMathExpr' p1, toMathExpr' p2)] + | _ -> [] | $ / $ as (mathExpr, mathExpr) with | Div $p1 $p2 -> [(toMathExpr' p1, toMathExpr' p2)] | _ -> [] @@ -57,10 +60,10 @@ | Div (Plus [Term 1 [(Quote $mexpr, 1)]]) (Plus [Term 1 []]) -> [toMathExpr' mexpr] | _ -> [] - | func $ $ $ $ as - (mathExpr, list mathExpr, list mathExpr, list indexExpr) with + | func $ $ $ as + (mathExpr, list mathExpr, list mathExpr) with | Div - (Plus [Term 1 [(Function $name $argnames $args $js, 1)]]) + (Plus [Term 1 [(Function $name $argnames $args, 1)]]) (Plus [Term 1 []]) -> [(name, argnames, args, js)] | _ -> [] @@ -89,15 +92,15 @@ | $ ^ #$k * $ as (mathExpr, multExpr) with | $tgt -> matchAll tgt as mathExpr with - | term _ (ncons $x #k $xs) -> (x, product' (map (uncurry (^')) xs)) + | term _ ($x ^ #k :: $xs) -> (x, product' (map (uncurry (^')) xs)) | $ ^ $ * $ as (mathExpr, integer, multExpr) with | $tgt -> matchAll tgt as mathExpr with - | term _ (ncons $x $n $xs) -> (x, n, product' (map (uncurry (^')) xs)) + | term _ ($x ^ $n :: $xs) -> (x, n, product' (map (uncurry (^')) xs)) | $ ^ $ as (mathExpr, integer) with | $tgt -> match tgt as mathExpr with - | term _ (ncons $x $n []) -> [(x, n)] + | term _ ($x ^ $n :: []) -> [(x, n)] | _ -> [] | $ * $ as (mathExpr, multExpr) with | $tgt -> @@ -260,7 +263,7 @@ def coefficients $f $x := let m := maximum (0 :: (matchAll f as mathExpr with - | poly (term $a (ncons #x $k $ts) :: _) / _ -> k)) + | poly (term $a (#x ^ $k :: $ts) :: _) / _ -> k)) in map (coefficient f x) (between 0 m) def coefficient $f $x $m := @@ -274,7 +277,7 @@ def coefficient' $f $x $m := sum (matchAll f as mathExpr with - | poly (term $a (ncons #x #m (!(#x :: _) & $ts)) :: _) / _ -> + | poly (term $a (#x ^ #m :: (!(#x :: _) & $ts)) :: _) / _ -> foldl (*') a (map (uncurry (^')) ts)) / denominator f def coefficient2 $f $x $y := diff --git a/lib/math/geometry/3d-euclidean-space.egi b/lib/math/geometry/3d-euclidean-space.egi --- a/lib/math/geometry/3d-euclidean-space.egi +++ b/lib/math/geometry/3d-euclidean-space.egi @@ -2,7 +2,7 @@ def metric := generateTensor - (\match as (integer, integer) with - | ($n, #n) -> 1 - | (_, _) -> 0) + (\match as list integer with + | [$n, #n] -> 1 + | _ -> 0) [3, 3] diff --git a/lib/math/geometry/4d-euclidean-space.egi b/lib/math/geometry/4d-euclidean-space.egi --- a/lib/math/geometry/4d-euclidean-space.egi +++ b/lib/math/geometry/4d-euclidean-space.egi @@ -2,7 +2,7 @@ def metric := generateTensor - (\match as (integer, integer) with - | ($n, #n) -> 1 - | (_, _) -> 0) + (\match as list integer with + | [$n, #n] -> 1 + | _ -> 0) [4, 4] diff --git a/lib/math/geometry/differential-form.egi b/lib/math/geometry/differential-form.egi --- a/lib/math/geometry/differential-form.egi +++ b/lib/math/geometry/differential-form.egi @@ -10,6 +10,10 @@ def wedge %X %Y := X !. Y +infixl expression 7 ∧ + +def (∧) := wedge + def Lie.wedge %X %Y := X !. Y - Y !. X def ι %X %Y := withSymbols [i] dfOrder Y * (X...~i . dfNormalize Y..._i) diff --git a/lib/math/geometry/minkowski-space.egi b/lib/math/geometry/minkowski-space.egi --- a/lib/math/geometry/minkowski-space.egi +++ b/lib/math/geometry/minkowski-space.egi @@ -2,8 +2,8 @@ def metric := generateTensor - (\match as (integer, integer) with - | (#1, #1) -> -1 - | ($n, #n) -> 1 - | (_, _) -> 0) + (\match as list integer with + | [#1, #1] -> -1 + | [$n, #n] -> 1 + | _ -> 0) [4, 4] diff --git a/lib/math/normalize.egi b/lib/math/normalize.egi --- a/lib/math/normalize.egi +++ b/lib/math/normalize.egi @@ -7,7 +7,7 @@ def mathNormalize $x := if isInteger x then x - else if containFunction `rtu x + else if containFunction 'rtu x then rewriteRuleForRtu (symbolNormalize x) else symbolNormalize x diff --git a/sample/math/geometry/riemann-curvature-tensor-of-S2.egi b/sample/math/geometry/riemann-curvature-tensor-of-S2.egi --- a/sample/math/geometry/riemann-curvature-tensor-of-S2.egi +++ b/sample/math/geometry/riemann-curvature-tensor-of-S2.egi @@ -9,7 +9,7 @@ def e_i_j := ∂/∂ X_j x~i -- Metric tensors -def g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2] +def g_i_j := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [2, 2] def g~i~j := M.inverse g_#_# assertEqual "Metric tensor" diff --git a/sample/math/geometry/riemann-curvature-tensor-of-S5-non-sym.egi b/sample/math/geometry/riemann-curvature-tensor-of-S5-non-sym.egi --- a/sample/math/geometry/riemann-curvature-tensor-of-S5-non-sym.egi +++ b/sample/math/geometry/riemann-curvature-tensor-of-S5-non-sym.egi @@ -12,7 +12,7 @@ def e_i_j := ∂/∂ X_j x~i -- Metric tensors -def g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [5, 5] +def g_i_j := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [5, 5] def g~i~j := M.inverse g_#_# -- Christoffel symbols diff --git a/sample/math/geometry/riemann-curvature-tensor-of-S5.egi b/sample/math/geometry/riemann-curvature-tensor-of-S5.egi --- a/sample/math/geometry/riemann-curvature-tensor-of-S5.egi +++ b/sample/math/geometry/riemann-curvature-tensor-of-S5.egi @@ -12,7 +12,7 @@ def e_i_j := ∂/∂ X_j x~i -- Metric tensors -def g{_i_j} := generateTensor (\x y -> V.* e_x_# e_y_#) [5, 5] +def g{_i_j} := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [5, 5] def g{~i~j} := M.inverse g_#_# -- Christoffel symbols diff --git a/sample/math/geometry/riemann-curvature-tensor-of-T2-non-sym.egi b/sample/math/geometry/riemann-curvature-tensor-of-T2-non-sym.egi --- a/sample/math/geometry/riemann-curvature-tensor-of-T2-non-sym.egi +++ b/sample/math/geometry/riemann-curvature-tensor-of-T2-non-sym.egi @@ -1,43 +1,43 @@ -- Parameters def x := [| θ, φ |] -def X := [| '(a * cos θ + b) * cos φ -- x - , '(a * cos θ + b) * sin φ -- y +def X := [| `(a * cos θ + b) * cos φ -- x + , `(a * cos θ + b) * sin φ -- y , a * sin θ -- z |] def e_i_j := ∂/∂ X_j x~i -- Metric tensors -def g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2] +def g_i_j := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [2, 2] def g~i~j := M.inverse g_#_# assertEqual "Metric tensor" g_#_# - [| [| a^2, 0 |], [| 0, '(a * cos θ + b)^2 |] |]_#_# + [| [| a^2, 0 |], [| 0, `(a * cos θ + b)^2 |] |]_#_# assertEqual "Metric tensor" g~#~# - [| [| 1 / a^2, 0 |], [| 0, 1 / '(a * cos θ + b)^2 |] |]~#~# + [| [| 1 / a^2, 0 |], [| 0, 1 / `(a * cos θ + b)^2 |] |]~#~# -- Christoffel symbols def Γ_i_j_k := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i) assertEqual "Christoffel symbols of the first kind" Γ_1_#_# - [| [| 0, 0 |], [| 0, '(a * cos θ + b) * a * sin θ |] |]_#_# + [| [| 0, 0 |], [| 0, `(a * cos θ + b) * a * sin θ |] |]_#_# assertEqual "Christoffel symbols of the first kind" Γ_2_#_# - [| [| 0, -1 * '(a * cos θ + b) * a * sin θ |], [| -1 * '(a * cos θ + b) * a * sin θ, 0 |] |]_#_# + [| [| 0, -1 * `(a * cos θ + b) * a * sin θ |], [| -1 * `(a * cos θ + b) * a * sin θ, 0 |] |]_#_# def Γ~i_j_k := withSymbols [m] g~i~m . Γ_m_j_k assertEqual "Christoffel symbols of the second kind" Γ~1_#_# - [| [| 0, 0 |], [| 0, '(a * cos θ + b) * sin θ / a |] |]_#_# + [| [| 0, 0 |], [| 0, `(a * cos θ + b) * sin θ / a |] |]_#_# assertEqual "Christoffel symbols of the second kind" Γ~2_#_# - [| [| 0, -1 * a * sin θ / '(a * cos θ + b) |], [| -1 * a * sin θ / '(a * cos θ + b), 0 |] |]_#_# + [| [| 0, -1 * a * sin θ / `(a * cos θ + b) |], [| -1 * a * sin θ / `(a * cos θ + b), 0 |] |]_#_# -- Riemann curvature def R~i_j_k_l := withSymbols [m] @@ -48,10 +48,10 @@ [| [| 0, 0 |], [| 0, 0 |] |]~#_# assertEqual "riemann curvature" R~#_#_1_2 - [| [| 0, '(a * cos θ + b) * cos θ / a |], [| -1 * a * cos θ / '(a * cos θ + b), 0 |] |]~#_# + [| [| 0, `(a * cos θ + b) * cos θ / a |], [| -1 * a * cos θ / `(a * cos θ + b), 0 |] |]~#_# assertEqual "riemann curvature" R~#_#_2_1 - [| [| 0, -1 * '(a * cos θ + b) * cos θ / a |], [| a * cos θ / '(a * cos θ + b), 0 |] |]~#_# + [| [| 0, -1 * `(a * cos θ + b) * cos θ / a |], [| a * cos θ / `(a * cos θ + b), 0 |] |]~#_# assertEqual "riemann curvature" R~#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]~#_# @@ -64,10 +64,10 @@ [| [| 0, 0 |], [| 0, 0 |] |]_#_# assertEqual "riemann curvature" R_#_#_1_2 - [| [| 0, a * '(a * cos θ + b) * cos θ |], [| - '(a * cos θ + b) * a * cos θ, 0 |] |]_#_# + [| [| 0, a * `(a * cos θ + b) * cos θ |], [| - `(a * cos θ + b) * a * cos θ, 0 |] |]_#_# assertEqual "riemann curvature" R_#_#_2_1 - [| [| 0, - a * '(a * cos θ + b) * cos θ |], [| '(a * cos θ + b) * a * cos θ, 0 |] |]_#_# + [| [| 0, - a * `(a * cos θ + b) * cos θ |], [| `(a * cos θ + b) * a * cos θ, 0 |] |]_#_# assertEqual "riemann curvature" R_#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]_#_# @@ -82,4 +82,4 @@ assertEqual "scalar curvature" scalarCurvature - (2 * cos θ / (a * '(a * cos θ + b))) + (2 * cos θ / (a * `(a * cos θ + b))) diff --git a/sample/math/geometry/riemann-curvature-tensor-of-T2.egi b/sample/math/geometry/riemann-curvature-tensor-of-T2.egi --- a/sample/math/geometry/riemann-curvature-tensor-of-T2.egi +++ b/sample/math/geometry/riemann-curvature-tensor-of-T2.egi @@ -1,43 +1,43 @@ -- Parameters def x := [| θ, φ |] -def X := [| '(a * cos θ + b) * cos φ -- x - , '(a * cos θ + b) * sin φ -- y +def X := [| `(a * cos θ + b) * cos φ -- x + , `(a * cos θ + b) * sin φ -- y , a * sin θ -- z |] def e_i_j := ∂/∂ X_j x~i -- Metric tensors -def g{_i_j} := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2] +def g{_i_j} := generateTensor (\[x, y] -> V.* e_x_# e_y_#) [2, 2] def g{~i~j} := M.inverse g_#_# assertEqual "Metric tensor" g_#_# - [| [| a^2, 0 |], [| 0, '(a * cos θ + b)^2 |] |]_#_# + [| [| a^2, 0 |], [| 0, `(a * cos θ + b)^2 |] |]_#_# assertEqual "Metric tensor" g~#~# - [| [| 1 / a^2, 0 |], [| 0, 1 / '(a * cos θ + b)^2 |] |]~#~# + [| [| 1 / a^2, 0 |], [| 0, 1 / `(a * cos θ + b)^2 |] |]~#~# -- Christoffel symbols def Γ_i{_j_k} := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i) assertEqual "Christoffel symbols of the first kind" Γ_1_#_# - [| [| 0, 0 |], [| 0, '(a * cos θ + b) * a * sin θ |] |]_#_# + [| [| 0, 0 |], [| 0, `(a * cos θ + b) * a * sin θ |] |]_#_# assertEqual "Christoffel symbols of the first kind" Γ_2_#_# - [| [| 0, -1 * '(a * cos θ + b) * a * sin θ |], [| -1 * '(a * cos θ + b) * a * sin θ, 0 |] |]_#_# + [| [| 0, -1 * `(a * cos θ + b) * a * sin θ |], [| -1 * `(a * cos θ + b) * a * sin θ, 0 |] |]_#_# def Γ~i{_j_k} := withSymbols [m] g~i~m . Γ_m_j_k assertEqual "Christoffel symbols of the second kind" Γ~1_#_# - [| [| 0, 0 |], [| 0, '(a * cos θ + b) * sin θ / a |] |]_#_# + [| [| 0, 0 |], [| 0, `(a * cos θ + b) * sin θ / a |] |]_#_# assertEqual "Christoffel symbols of the second kind" Γ~2_#_# - [| [| 0, -1 * a * sin θ / '(a * cos θ + b) |], [| -1 * a * sin θ / '(a * cos θ + b), 0 |] |]_#_# + [| [| 0, -1 * a * sin θ / `(a * cos θ + b) |], [| -1 * a * sin θ / `(a * cos θ + b), 0 |] |]_#_# -- Riemann curvature def R~i_j_k_l := withSymbols [m] @@ -48,10 +48,10 @@ [| [| 0, 0 |], [| 0, 0 |] |]~#_# assertEqual "riemann curvature" R~#_#_1_2 - [| [| 0, '(a * cos θ + b) * cos θ / a |], [| -1 * a * cos θ / '(a * cos θ + b), 0 |] |]~#_# + [| [| 0, `(a * cos θ + b) * cos θ / a |], [| -1 * a * cos θ / `(a * cos θ + b), 0 |] |]~#_# assertEqual "riemann curvature" R~#_#_2_1 - [| [| 0, -1 * '(a * cos θ + b) * cos θ / a |], [| a * cos θ / '(a * cos θ + b), 0 |] |]~#_# + [| [| 0, -1 * `(a * cos θ + b) * cos θ / a |], [| a * cos θ / `(a * cos θ + b), 0 |] |]~#_# assertEqual "riemann curvature" R~#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]~#_# @@ -64,10 +64,10 @@ [| [| 0, 0 |], [| 0, 0 |] |]_#_# assertEqual "riemann curvature" R_#_#_1_2 - [| [| 0, a * '(a * cos θ + b) * cos θ |], [| - '(a * cos θ + b) * a * cos θ, 0 |] |]_#_# + [| [| 0, a * `(a * cos θ + b) * cos θ |], [| - `(a * cos θ + b) * a * cos θ, 0 |] |]_#_# assertEqual "riemann curvature" R_#_#_2_1 - [| [| 0, - a * '(a * cos θ + b) * cos θ |], [| '(a * cos θ + b) * a * cos θ, 0 |] |]_#_# + [| [| 0, - a * `(a * cos θ + b) * cos θ |], [| `(a * cos θ + b) * a * cos θ, 0 |] |]_#_# assertEqual "riemann curvature" R_#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]_#_# @@ -82,4 +82,4 @@ assertEqual "scalar curvature" scalarCurvature - (2 * cos θ / (a * '(a * cos θ + b))) + (2 * cos θ / (a * `(a * cos θ + b))) diff --git a/sample/math/geometry/thurston-non-sym.egi b/sample/math/geometry/thurston-non-sym.egi --- a/sample/math/geometry/thurston-non-sym.egi +++ b/sample/math/geometry/thurston-non-sym.egi @@ -8,15 +8,15 @@ [|[| 1, 0, 0, 0 |], [| 0, 1, 0, 0 |], [| 0, 0, κ / (sqrt β), (-1 * θ₂ * κ) / (sqrt β) |], - [| 0, 0, (-1 * θ₂ * κ) / (sqrt β), ('(1 + θ₂) * κ) / (sqrt β) |]|] + [| 0, 0, (-1 * θ₂ * κ) / (sqrt β), (`(1 + θ₂) * κ) / (sqrt β) |]|] def g~i~j := [|[| 1, 0, 0, 0 |], [| 0, 1, 0, 0 |], - [| 0, 0, '(1 + θ₂) / (κ * (sqrt β)), θ₂ / ((sqrt β) * κ) |], + [| 0, 0, `(1 + θ₂) / (κ * (sqrt β)), θ₂ / ((sqrt β) * κ) |], [| 0, 0, θ₂ / ((sqrt β) * κ), 1 / ((sqrt β) * κ) |]|] -def β := '(1 + θ₂ - θ₂^2) +def β := `(1 + θ₂ - θ₂^2) def Γ~c_a_b := withSymbols [e] (1 / 2) * g~c~e . (∂/∂ g_b_e x~a + ∂/∂ g_a_e x~b - ∂/∂ g_a_b x~e) @@ -52,25 +52,25 @@ def δ := generateTensor - (\x y -> match (x, y) as (integer, integer) with - | ($n, #n) -> 1 - | (_, _) -> 0) + (\match as list integer with + | [$n, #n] -> 1 + | _ -> 0) [5, 5] def R'_i_j_k~l := generateTensor - (\x y z w -> match (x, y, z, w) as (integer, integer, integer, integer) with - | (#1, #1, _, _) -> 0 - | (_, _, #1, #1) -> 0 - | (#1, $b, #1, $d) -> -1 * p^2 * δ~(b - 1)_(d - 1) - | ($a, #1, #1, $d) -> p^2 * δ~(a - 1)_(d - 1) - | (#1, $b, $c, #1) -> p^2 * g_(b - 1)_(c - 1) - | ($a, #1, $c, #1) -> -1 * p^2 * g_(a - 1)_(c - 1) - | (#1, $b, $c, $d) -> -1 * p * ∇J_(b - 1)_(c - 1)~(d - 1) - | ($a, #1, $c, $d) -> p * ∇J_(a - 1)_(c - 1)~(d - 1) - | ($a, $b, #1, $d) -> -1 * p * ∇J~(d - 1)_(a - 1)_(b - 1) - | ($a, $b, $c, #1) -> p * ∇J_(c - 1)_(a - 1)_(b - 1) - | ($a, $b, $c, $d) -> R_(a - 1)_(b - 1)_(c - 1)~(d - 1) + (\match as list integer with + | [#1, #1, _, _] -> 0 + | [_, _, #1, #1] -> 0 + | [#1, $b, #1, $d] -> -1 * p^2 * δ~(b - 1)_(d - 1) + | [$a, #1, #1, $d] -> p^2 * δ~(a - 1)_(d - 1) + | [#1, $b, $c, #1] -> p^2 * g_(b - 1)_(c - 1) + | [$a, #1, $c, #1] -> -1 * p^2 * g_(a - 1)_(c - 1) + | [#1, $b, $c, $d] -> -1 * p * ∇J_(b - 1)_(c - 1)~(d - 1) + | [$a, #1, $c, $d] -> p * ∇J_(a - 1)_(c - 1)~(d - 1) + | [$a, $b, #1, $d] -> -1 * p * ∇J~(d - 1)_(a - 1)_(b - 1) + | [$a, $b, $c, #1] -> p * ∇J_(c - 1)_(a - 1)_(b - 1) + | [$a, $b, $c, $d] -> R_(a - 1)_(b - 1)_(c - 1)~(d - 1) + -1 * p^2 * J_(b - 1)_(c - 1) * J_(a - 1)~(d - 1) + p^2 * J_(a - 1)_(c - 1) * J_(b - 1)~(d - 1) + 2 * p^2 * J_(a - 1)_(b - 1) * J_(c - 1)~(d - 1)) diff --git a/sample/math/geometry/thurston.egi b/sample/math/geometry/thurston.egi --- a/sample/math/geometry/thurston.egi +++ b/sample/math/geometry/thurston.egi @@ -8,15 +8,15 @@ [|[| 1, 0, 0, 0 |], [| 0, 1, 0, 0 |], [| 0, 0, κ / (sqrt β), (-1 * θ₂ * κ) / (sqrt β) |], - [| 0, 0, (-1 * θ₂ * κ) / (sqrt β), ('(1 + θ₂) * κ) / (sqrt β) |]|] + [| 0, 0, (-1 * θ₂ * κ) / (sqrt β), (`(1 + θ₂) * κ) / (sqrt β) |]|] def g~i~j := [|[| 1, 0, 0, 0 |], [| 0, 1, 0, 0 |], - [| 0, 0, '(1 + θ₂) / (κ * (sqrt β)), θ₂ / ((sqrt β) * κ) |], + [| 0, 0, `(1 + θ₂) / (κ * (sqrt β)), θ₂ / ((sqrt β) * κ) |], [| 0, 0, θ₂ / ((sqrt β) * κ), 1 / ((sqrt β) * κ) |]|] -def β := '(1 + θ₂ - θ₂^2) +def β := `(1 + θ₂ - θ₂^2) def Γ~c_a_b := withSymbols [e] (1 / 2) * g~c~e . (∂/∂ g_b_e x~a + ∂/∂ g_a_e x~b - ∂/∂ g_a_b x~e) @@ -34,9 +34,13 @@ def J_a~c := J_a_b . g~b~c +def ∇_c T~(a_1)...~(a_r)_(b_1)..._(b_k) := + ∂/∂ T~(a_1)...~(a_r)_(b_1)..._(b_k) x~c + + sum (map (\i -> Γ~(a_i)_d_c . T~(a_1)...~(a_(i-1))~d~(a_(i+1))...~(a_r)_(b_1)..._(b_k)) [1..r]) + - sum (map (\i -> Γ~d_(b_i)_c . T~(a_1)...~(a_r)_(b_1)..._(b_(i-1))_d_(b_(i+1))..._(b_k)) [1..k]) + def ∇J_m_a_b := - withSymbols [n] - ∂/∂ J_a_b x~m + Γ~n_m_a . J_n_b + Γ~n_m_b . J_a_n + ∇_m J_a_b -- ∂/∂ J_a_b x~m - Γ~n_m_a . J_n_b - Γ~n_m_b . J_a_n def ∇J~m_a_b := withSymbols [t] @@ -52,25 +56,25 @@ def δ := generateTensor - (\x y -> match (x, y) as (integer, integer) with - | ($n, #n) -> 1 - | (_, _) -> 0) + (\match as list integer with + | [$n, #n] -> 1 + | [_, _] -> 0) [5, 5] def R'[_i_j]_k~l := generateTensor - (\x y z w -> match (x, y, z, w) as (integer, integer, integer, integer) with - | (#1, #1, _, _) -> 0 - | (_, _, #1, #1) -> 0 - | (#1, $b, #1, $d) -> -1 * p^2 * δ~(b - 1)_(d - 1) - | ($a, #1, #1, $d) -> p^2 * δ~(a - 1)_(d - 1) - | (#1, $b, $c, #1) -> p^2 * g_(b - 1)_(c - 1) - | ($a, #1, $c, #1) -> -1 * p^2 * g_(a - 1)_(c - 1) - | (#1, $b, $c, $d) -> -1 * p * ∇J_(b - 1)_(c - 1)~(d - 1) - | ($a, #1, $c, $d) -> p * ∇J_(a - 1)_(c - 1)~(d - 1) - | ($a, $b, #1, $d) -> -1 * p * ∇J~(d - 1)_(a - 1)_(b - 1) - | ($a, $b, $c, #1) -> p * ∇J_(c - 1)_(a - 1)_(b - 1) - | ($a, $b, $c, $d) -> R_(a - 1)_(b - 1)_(c - 1)~(d - 1) + (\match as list integer with + | [#1, #1, _, _] -> 0 + | [_, _, #1, #1] -> 0 + | [#1, $b, #1, $d] -> -1 * p^2 * δ~(b - 1)_(d - 1) + | [$a, #1, #1, $d] -> p^2 * δ~(a - 1)_(d - 1) + | [#1, $b, $c, #1] -> p^2 * g_(b - 1)_(c - 1) + | [$a, #1, $c, #1] -> -1 * p^2 * g_(a - 1)_(c - 1) + | [#1, $b, $c, $d] -> -1 * p * ∇J_(b - 1)_(c - 1)~(d - 1) + | [$a, #1, $c, $d] -> p * ∇J_(a - 1)_(c - 1)~(d - 1) + | [$a, $b, #1, $d] -> -1 * p * ∇J~(d - 1)_(a - 1)_(b - 1) + | [$a, $b, $c, #1] -> p * ∇J_(c - 1)_(a - 1)_(b - 1) + | [$a, $b, $c, $d] -> R_(a - 1)_(b - 1)_(c - 1)~(d - 1) + -1 * p^2 * J_(b - 1)_(c - 1) * J_(a - 1)~(d - 1) + p^2 * J_(a - 1)_(c - 1) * J_(b - 1)~(d - 1) + 2 * p^2 * J_(a - 1)_(b - 1) * J_(c - 1)~(d - 1)) diff --git a/sample/math/number/5th-root-of-unity.egi b/sample/math/number/5th-root-of-unity.egi new file mode 100644 --- /dev/null +++ b/sample/math/number/5th-root-of-unity.egi @@ -0,0 +1,53 @@ +-- +-- This file has been auto-generated by egison-translator. +-- + +def z := rtu 5 + +def a11 := z ^ 1 + z ^ 4 + +def a12 := z ^ 2 + z ^ 3 + +def b10 := a11 + a12 + +def b11 := a11 - a12 + +def b12 := a12 - a11 + +assertEqual "b10" b10 (-1) + +def b10' := b10 + +def b11' := sqrt (b11 ^ 2) + +def a11' := (b10' + b11') / 2 + +def a12' := (b10' - b11') / 2 + +def a21 := z ^ 1 - z ^ 4 + +def a22 := z ^ 2 - z ^ 3 + +def b20 := a21 + a22 + +def b21 := a21 - a22 + +def b22 := a22 - a21 + +def b20' := sqrt ((-3) + 4 * a12') + +def b21' := sqrt ((-3) + 4 * a11') + +def a21' := (b20' + b21') / 2 + +def a22' := (b20' - b21') / 2 + +def z1' := (a11' + a21') / 2 + +assertEqual + "5th-root-of-unity" + z1' + ((-1 + sqrt 5 + sqrt (-5 - 2 * sqrt 5) + sqrt (-5 + 2 * sqrt 5)) / 4) + + +z1'^5 diff --git a/sample/math/number/7th-root-of-unity.egi b/sample/math/number/7th-root-of-unity.egi new file mode 100644 --- /dev/null +++ b/sample/math/number/7th-root-of-unity.egi @@ -0,0 +1,51 @@ +-- +-- This file has been auto-generated by egison-translator. +-- + +def z := rtu 7 + +def a11 := z ^ 1 + z ^ 6 + +def a12 := z ^ 2 + z ^ 5 + +def a13 := z ^ 3 + z ^ 4 + +def b10 := a11 + a12 + a13 + +def b10' := b10 + +b10' + +def b11 := a11 + w * a12 + w ^ 2 * a13 + +def b12 := a13 + w * a11 + w ^ 2 * a12 + +def b13 := a12 + w * a13 + w ^ 2 * a11 + +def b11' := rt 3 (b11 * b12 * b13) + +b11' + +def b14 := a11 + w * a13 + w ^ 2 * a12 + +def b15 := a12 + w * a11 + w ^ 2 * a13 + +def b16 := a13 + w * a12 + w ^ 2 * a11 + +def b14' := rt 3 (b14 * b15 * b16) + +b14' + +def a11' := (b10' + b11' + b14') / 3 + +a11' + +def z1' := fst (qF' 1 (- a11') 1) + +z1' + +--((-1) + rt 3 (14 + 21 * w) + rt 3 ((-7) + (-21) * w) + +--sqrt +-- ((-35) + (-2) * rt 3 (14 + 21 * w) + (-2) * rt 3 ((-7) + (-21) * w) + +-- rt 3 (14 + 21 * w) ^ 2 + rt 3 ((-7) + (-21) * w) ^ 2 + +-- 2 * rt 3 (14 + 21 * w) * rt 3 ((-7) + (-21) * w))) / 6 diff --git a/sample/math/number/tribonacci.egi b/sample/math/number/tribonacci.egi --- a/sample/math/number/tribonacci.egi +++ b/sample/math/number/tribonacci.egi @@ -2,10 +2,10 @@ def A := generateTensor - (\x y -> match (x, y) as (integer, integer) with - | (#1, _) -> 1 - | ($x, #(x - 1)) -> 1 - | (_, _) -> 0) + (\match as list integer with + | [#1, _] -> 1 + | [$x, #(x - 1)] -> 1 + | _ -> 0) [m, m] A @@ -13,7 +13,7 @@ def B := generateTensor - (\x -> if x = 1 then 1 else 0) + (\[x] -> if x = 1 then 1 else 0) [m] B diff --git a/sample/sat/dp.egi b/sample/sat/dp.egi --- a/sample/sat/dp.egi +++ b/sample/sat/dp.egi @@ -1,7 +1,3 @@ --- --- This file has been auto-generated by egison-translator. --- - def deleteLiteral l cnf := map (\c -> matchAll c as multiset integer with @@ -22,7 +18,9 @@ def dp vars cnf := match (vars, cnf) as (multiset integer, multiset (multiset integer)) with + -- satisfiable | (_, []) -> True + -- unsatisfiable | (_, [] :: _) -> False -- 1-literal rule | (_, [$l] :: _) -> dp (delete (abs l) vars) (assignTrue l cnf) @@ -35,11 +33,12 @@ dp vs ((resolveOn v cnf) ++ (deleteClausesWith v (deleteClausesWith (neg v) cnf))) -dp [1] [[1]] -dp [1] [[1], [-1]] -dp [1, 2, 3] [[1, 2], [-1, 3], [1, -3]] -dp [1, 2] [[1, 2], [-1, -2], [1, -2]] -dp [1, 2] [[1, 2], [-1, -2], [1, -2], [-1, 2]] -dp [1, 2, 3, 4, 5] - [[-1, -2, 3], [-1, -2, -3], [1, 2, 3, 4], [-4, -2, 3], [5, 1, 2, -3], [-3, 1, -5], [1, -2, 3, 4], [1, -2, -3, 5]] -dp [1, 2] [[-1, -2], [1]] +assert "dp" (dp [1] [[1]]) +assert "dp" (not (dp [1] [[1], [-1]])) +assert "dp" (dp [1, 2, 3] [[1, 2], [-1, 3], [1, -3]]) +assert "dp" (dp [1, 2] [[1, 2], [-1, -2], [1, -2]]) +assert "dp" (not (dp [1, 2] [[1, 2], [-1, -2], [1, -2], [-1, 2]])) +assert "dp" (dp [1, 2, 3, 4, 5] + [[-1, -2, 3], [-1, -2, -3], [1, 2, 3, 4], [-4, -2, 3], + [5, 1, 2, -3], [-3, 1, -5], [1, -2, 3, 4], [1, -2, -3, 5]]) +assert "dp" (dp [1, 2] [[-1, -2], [1]]) diff --git a/test/CLITest.hs b/test/CLITest.hs new file mode 100644 --- /dev/null +++ b/test/CLITest.hs @@ -0,0 +1,88 @@ +module Main (main) where + +import Data.Version (showVersion) +import System.Process (readProcess) + +import Test.Framework (defaultMain) +import Test.Framework.Providers.HUnit (hUnitTestToTests) +import Test.HUnit + +import Language.Egison (version) + +main :: IO () +main = defaultMain . hUnitTestToTests . test $ TestList + [ TestLabel "load-file option" . TestCase $ assertEgisonCmd + (interpreter "1\n") + ["--load-file", "test/fixture/a.egi"] + "x" + , TestLabel "test option" . TestCase $ assertEgisonCmd + "3\n\"This is the third line\"\n" + ["--test", "test/fixture/b.egi"] + "" + , TestLabel "eval option" . TestCase $ assertEgisonCmd + "[[], [1], [1, 2], [1, 2, 3]]\n" + ["--eval", "matchAll [1,2,3] as list something with $x ++ _ -> x"] + "" + , TestLabel "command option" . TestCase $ assertEgisonCmd + "1\n" + ["--command", "print (show 1)"] + "" + , TestLabel "TSV option" . TestCase $ assertEgisonCmd + "2\n3\n5\n7\n11\n13\n17\n19\n23\n29\n" + ["-T", "-e", "take 10 primes"] + "" + , TestLabel "TSV option with tab" . TestCase $ assertEgisonCmd + "1\t2\t3\n4\t5\n" + ["-T", "-e", "[[1, 2, 3], [4, 5]]"] + "" + , TestLabel "substitute option" . TestCase $ assertEgisonCmd + "10\n11\n12\n13\n14\n15\n" + ["--substitute", "\\matchAll as list integer with _ ++ $x :: _ ++ #(x + 5) :: _ -> x"] + "10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20" + , TestLabel "map option" . TestCase $ assertEgisonCmd + "3\n4\n5\n6\n7\n" + ["--map", "\\x -> x + 2"] + "1\n2\n3\n4\n5" + , TestLabel "filter option" . TestCase $ assertEgisonCmd + "2\n3\n5\n7\n" + ["--filter", "isPrime"] + "1\n2\n3\n4\n5\n6\n7\n8\n9\n10" + , TestLabel "field option" . TestCase $ assertEgisonCmd + "(10, [2, 5])\n(11, [11])\n(12, [2, 2, 3])\n(13, [13])\n(14, [2, 7])\n(15, [3, 5])\n" + ["--field", "2c", "-m", "\\x -> x"] + "10\t2\t5\n11\t11\n12\t2\t2\t3\n13\t13\n14\t2\t7\n15\t3\t5" + , TestLabel "math option" . TestCase $ assertEgisonCmd + (interpreter "#latex|\\frac{x}{y}|#\n") + ["--math", "latex"] + "x / y" + , TestLabel "sexpr option" . TestCase $ assertEgisonCmd + (interpreter "3\n") + ["--sexpr-syntax"] + "(+ 1 2)" + , TestLabel "execute main function" . TestCase $ assertEgisonCmd + "[\"a\", \"b\", \"c\"]\n" + ["test/fixture/c.egi", "a", "b", "c"] + "" + , TestLabel "io function" . TestCase $ assertEgisonCmd + "display write print\n3\n1 + 2 = 3\n" + ["test/lib/core/io.egi"] + "" + ] + +assertEgisonCmd + :: String -- The expected value + -> [String] -- any arguments for egison command + -> String -- standard input for egison command + -> Assertion +assertEgisonCmd expected args input = do + actual <- readProcess "stack" ("exec" : "--" : "egison" : args) input + assertEqual "" expected actual + +interpreter :: String -> String +interpreter output = concat + [ "Egison Version ", showVersion version, "\n" + , "https://www.egison.org\n" + , "Welcome to Egison Interpreter!\n" + , "> ", output + , "> Leaving Egison Interpreter.\n" + ] diff --git a/test/OptionsTest.hs b/test/OptionsTest.hs deleted file mode 100644 --- a/test/OptionsTest.hs +++ /dev/null @@ -1,84 +0,0 @@ -module Main (main) where - -import Data.Version (showVersion) -import System.Process (readProcess) - -import Test.Framework (defaultMain) -import Test.Framework.Providers.HUnit (hUnitTestToTests) -import Test.HUnit - -import Language.Egison (version) - -main :: IO () -main = defaultMain . hUnitTestToTests . test $ TestList - [ TestLabel "load-file option" . TestCase $ assertEgisonCmd - (interpreter "1\n") - ["--load-file", "test/fixture/a.egi"] - "x" - , TestLabel "test option" . TestCase $ assertEgisonCmd - "3\n\"This is the third line\"\n" - ["--test", "test/fixture/b.egi"] - "" - , TestLabel "eval option" . TestCase $ assertEgisonCmd - "[[], [1], [1, 2], [1, 2, 3]]\n" - ["--eval", "matchAll [1,2,3] as list something with $x ++ _ -> x"] - "" - , TestLabel "command option" . TestCase $ assertEgisonCmd - "1\n" - ["--command", "print (show 1)"] - "" - , TestLabel "TSV option" . TestCase $ assertEgisonCmd - "2\n3\n5\n7\n11\n13\n17\n19\n23\n29\n" - ["-T", "-e", "take 10 primes"] - "" - , TestLabel "TSV option with tab" . TestCase $ assertEgisonCmd - "1\t2\t3\n4\t5\n" - ["-T", "-e", "[[1, 2, 3], [4, 5]]"] - "" - , TestLabel "substitute option" . TestCase $ assertEgisonCmd - "10\n11\n12\n13\n14\n15\n" - ["--substitute", "\\matchAll as list integer with _ ++ $x :: _ ++ #(x + 5) :: _ -> x"] - "10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20" - , TestLabel "map option" . TestCase $ assertEgisonCmd - "3\n4\n5\n6\n7\n" - ["--map", "\\x -> x + 2"] - "1\n2\n3\n4\n5" - , TestLabel "filter option" . TestCase $ assertEgisonCmd - "2\n3\n5\n7\n" - ["--filter", "isPrime"] - "1\n2\n3\n4\n5\n6\n7\n8\n9\n10" - , TestLabel "field option" . TestCase $ assertEgisonCmd - "(10, [2, 5])\n(11, [11])\n(12, [2, 2, 3])\n(13, [13])\n(14, [2, 7])\n(15, [3, 5])\n" - ["--field", "2c", "-m", "\\x -> x"] - "10\t2\t5\n11\t11\n12\t2\t2\t3\n13\t13\n14\t2\t7\n15\t3\t5" - , TestLabel "math option" . TestCase $ assertEgisonCmd - (interpreter "#latex|\\frac{x}{y}|#\n") - ["--math", "latex"] - "x / y" - , TestLabel "sexpr option" . TestCase $ assertEgisonCmd - (interpreter "3\n") - ["--sexpr-syntax"] - "(+ 1 2)" - , TestLabel "execute main function" . TestCase $ assertEgisonCmd - "[\"a\", \"b\", \"c\"]\n" - ["test/fixture/c.egi", "a", "b", "c"] - "" - ] - -assertEgisonCmd - :: String -- The expected value - -> [String] -- any arguments for egison command - -> String -- standard input for egison command - -> Assertion -assertEgisonCmd expected args input = do - actual <- readProcess "stack" ("exec" : "--" : "egison" : args) input - assertEqual "" expected actual - -interpreter :: String -> String -interpreter output = concat - [ "Egison Version ", showVersion version, "\n" - , "https://www.egison.org\n" - , "Welcome to Egison Interpreter!\n" - , "> ", output - , "> Leaving Egison Interpreter.\n" - ] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -26,6 +26,9 @@ , "test/lib/core/maybe.egi" , "test/lib/core/number.egi" , "test/lib/core/order.egi" + , "test/lib/core/random.egi" + , "test/lib/core/shell.egi" + , "test/lib/core/sort.egi" , "test/lib/core/string.egi" , "test/lib/math/algebra.egi" , "test/lib/math/analysis.egi" diff --git a/test/lib/core/assoc.egi b/test/lib/core/assoc.egi --- a/test/lib/core/assoc.egi +++ b/test/lib/core/assoc.egi @@ -10,31 +10,6 @@ (fromAssoc [(x, 2), (y, 1)]) [x, x, y] -assertEqual "assocList" - (matchAll [(x, 2), (y, 1)] as assocList something with - | $a :: _ -> a) - [x] - -assertEqual "assocList" - (matchAll [(x, 3), (y, 2), (z, 1)] as assocList something with - | ncons $a #2 $r -> (a, r)) - [(x, [(x, 1), (y, 2), (z, 1)])] - -assertEqual "assocList" - (matchAll [(x, 1), (y, 2), (z, 3)] as assocList something with - | ncons $a #2 $r -> (a, r)) - [] - -assertEqual "assocList" - (matchAll [(x, 3), (y, 2), (z, 1)] as assocList something with - | ncons $a $n $r -> (a, n, r)) - [(x, 3, [(y, 2), (z, 1)])] - -assertEqual "assocList" - (matchAll [(x, 3), (y, 2), (z, 1)] as assocList something with - | ncons $a $n $r -> (a, n, r)) - [(x, 3, [(y, 2), (z, 1)])] - assertEqual "assocMultiset" (matchAll [(x, 2), (y, 1)] as assocMultiset something with | $a :: _ -> a) @@ -42,22 +17,22 @@ assertEqual "assocMultiset" (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with - | ncons #z $n $r -> (n, r)) + | #z ^ $n :: $r -> (n, r)) [(1, [(x, 3), (y, 2)])] assertEqual "assocMultiset" (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with - | ncons $a #2 $r -> (a, r)) + | $a ^ #2 :: $r -> (a, r)) [(x, [(x, 1), (y, 2), (z, 1)]), (y, [(x, 3), (z, 1)])] assertEqual "assocMultiset" (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with - | ncons #y #1 $r -> r) + | #y ^ #1 :: $r -> r) [[(x, 3), (y, 1), (z, 1)]] assertEqual "assocMultiset" (matchAll [(x, 3), (y, 2), (z, 1)] as assocMultiset something with - | ncons $a $n $r -> (a, n, r)) + | $a ^ $n :: $r -> (a, n, r)) [(x, 3, [(y, 2), (z, 1)]), (y, 2, [(x, 3), (z, 1)]), (z, 1, [(x, 3), (y, 2)])] assertEqual "AC.intersect" diff --git a/test/lib/core/io.egi b/test/lib/core/io.egi new file mode 100644 --- /dev/null +++ b/test/lib/core/io.egi @@ -0,0 +1,51 @@ +def main args := do + display "display" + write " write" + print " print" + testPrintToPort + testEach + testEachLineFromPort + let _ := return $ debug (1 + 2) + let _ := return $ debug2 "1 + 2 = " (1 + 2) + return () + +def testPrintToPort := do + let op := openOutputFile "out.txt" + displayToPort op "displayToPort" + writeToPort op " writeToPort" + printToPort op " printToPort" + closeOutputPort op + let out := readProcess "cat" ["out.txt"] "" + let _ := return $ + assertEqual "testPrintToPort" (S.split "\n" out) + ["displayToPort writeToPort printToPort", ""] + let _ := readProcess "rm" ["out.txt"] "" + return () + +def testEach := do + let op := openOutputFile "out.txt" + each (printToPort op) ["foo", "bar"] + closeOutputPort op + let out := readProcess "cat" ["out.txt"] "" + let _ := return $ + assertEqual "testEach" (S.split "\n" out) ["foo", "bar", ""] + let _ := readProcess "rm" ["out.txt"] "" + return () + +def testEachLineFromPort := do + let ip := openInputFile "test/fixture/lorem-ipsum.txt" + let op := openOutputFile "out.txt" + eachLineFromPort ip (\x -> printToPort op (S.map upperCase x)) + closeInputPort ip + closeOutputPort op + let out := readProcess "cat" ["out.txt"] "" + let _ := return $ + assertEqual "testEachLineFromPort" (S.split "\n" out) + [ "LOREM IPSUM DOLOR SIT AMET, CONSECTETUR ADIPISCING ELIT, SED DO EIUSMOD TEMPOR INCIDIDUNT UT LABORE ET DOLORE MAGNA ALIQUA." + , "UT ENIM AD MINIM VENIAM, QUIS NOSTRUD EXERCITATION ULLAMCO LABORIS NISI UT ALIQUIP EX EA COMMODO CONSEQUAT." + , "DUIS AUTE IRURE DOLOR IN REPREHENDERIT IN VOLUPTATE VELIT ESSE CILLUM DOLORE EU FUGIAT NULLA PARIATUR." + , "EXCEPTEUR SINT OCCAECAT CUPIDATAT NON PROIDENT, SUNT IN CULPA QUI OFFICIA DESERUNT MOLLIT ANIM ID EST LABORUM." + , "" + ] + let _ := readProcess "rm" ["out.txt"] "" + return () diff --git a/test/lib/core/number.egi b/test/lib/core/number.egi --- a/test/lib/core/number.egi +++ b/test/lib/core/number.egi @@ -70,7 +70,7 @@ assertEqual "nAdic" (nAdic 2 10) [1, 0, 1, 0] assertEqual "rtod" - ((\(x, y) -> (x, take 10 y)) (rtod (6 / 35))) + ((2)#(%1, take 10 %2) (rtod (6 / 35))) (0, [1, 7, 1, 4, 2, 8, 5, 7, 1, 4]) assertEqual "rtod'" (rtod' (6 / 35)) (0, [1], [7, 1, 4, 2, 8, 5]) @@ -106,7 +106,7 @@ assertEqual "regularContinuedFractionOfSqrt case 1" - ((\(x, y) -> (x, take 10 y)) (regularContinuedFractionOfSqrt 2)) + ((2)#(%1, take 10 %2) (regularContinuedFractionOfSqrt 2)) (1, [2, 2, 2, 2, 2, 2, 2, 2, 2, 2]) assertEqual diff --git a/test/lib/core/order.egi b/test/lib/core/order.egi --- a/test/lib/core/order.egi +++ b/test/lib/core/order.egi @@ -1,43 +1,50 @@ -assertEqual "compare" - (compare 10 10) - Equal - -assertEqual "compare" - (compare 11 10) - Greater - -assertEqual "compare" - (compare 10 11) - Less +assertEqual "compare" (compare 10 10) Equal +assertEqual "compare" (compare 11 10) Greater +assertEqual "compare" (compare 10 11) Less -assertEqual "min" - (min 20 5) - 5 +assertEqual "compareC" (compareC [1, 2] [1]) Greater +assertEqual "compareC" (compareC [1] [1, 2]) Less +assertEqual "compareC" (compareC [1, 2] [1, 3]) Less +assertEqual "compareC" (compareC [1, 3] [1, 3]) Equal -assertEqual "minimum" - (minimum [20, 5, 12]) - 5 +assertEqual "min" (min 20 5) 5 +assertEqual "max" (max 5 30) 30 -assertEqual "min/fn" - (min/fn compare [10, 20, 5, 20, 30]) - 5 +assertEqual "min/fn" (min/fn compare [10, 20, 5, 20, 30]) 5 +assertEqual "max/fn" (max/fn compare [10, 20, 5, 20, 30]) 30 -assertEqual "max" - (max 5 30) - 30 +assertEqual "minimum" (minimum [20, 5, 12]) 5 +assertEqual "maximum" (maximum [5, 30, 23]) 30 -assertEqual "maximum" - (maximum [5, 30, 23]) - 30 +assertEqual "splitByOrdering" + (splitByOrdering 2 [1, 2, 3, 2, 3, 4, 5]) + ([1], [2, 2], [3, 3, 4, 5]) -assertEqual "max/fn" - (max/fn compare [10, 20, 5, 20, 30]) - 30 +assertEqual "splitByOrdering/fn" + (splitByOrdering/fn (\_ _ -> Equal) 2 [1, 2, 3, 4, 5]) + ([], [1, 2, 3, 4, 5], []) assertEqual "sort" (sort [10, 20, 5, 20, 30]) [5, 10, 20, 20, 30] assertEqual "sort/fn" - (sort/fn compare [10, 20, 5, 20, 30]) - [5, 10, 20, 20, 30] + (sort/fn + (\x y -> match compare x y as ordering with + | greater -> Less + | less -> Greater + | equal -> Equal) + [10, 20, 5, 20, 30]) + [30, 20, 20, 10, 5] + +assertEqual "sortStrings" + (sortStrings ["banana", "apple", "chocolate"]) + ["apple", "banana", "chocolate"] + +assertEqual "minimize" + (minimize S.length ["banana", "apple", "chocolate"]) + "apple" + +assertEqual "maximize" + (maximize S.length ["banana", "apple", "chocolate"]) + "chocolate" diff --git a/test/lib/core/random.egi b/test/lib/core/random.egi new file mode 100644 --- /dev/null +++ b/test/lib/core/random.egi @@ -0,0 +1,50 @@ +assert "rands" + (all (`member` [1..10]) (take 5 (rands 1 10))) + +assert "pureRand" + (member (pureRand 1 10) [1..10]) + +assertEqual "randomize" (randomize []) [] +assert "randomize" (eqAs (multiset integer) (randomize [1, 2, 3]) [1, 2, 3]) + +assert "R.between" + (eqAs (multiset integer) (R.between 1 10) [1..10]) + +assert "R.multiset" + (member + (matchAll [1, 2] as R.multiset integer with $n :: $ns -> (n, ns)) + [[(1, [2]), (2, [1])], [(2, [1]), (1, [2])]]) + +assertEqual "R.multiset" + (matchAll [1, 2] as R.multiset integer with #1 :: $ns -> ns) + [[2]] + +assert "R.set" + (member + (matchAll [1, 2] as R.set integer with $n :: $ns -> (n, ns)) + [[(1, [1, 2]), (2, [1, 2])], [(2, [1, 2]), (1, [1, 2])]]) + +assertEqual "R.set" + (matchAll [1, 2] as R.set integer with #1 :: $ns -> ns) + [[1, 2]] + +assert "R.uncons" + (member (R.uncons [1, 2]) [(1, [2]), (2, [1])]) + +assert "R.head" + (member (R.head [1..10]) [1..10]) + +assert "R.tail" + (member + (R.tail [1..5]) + [[ 2, 3, 4, 5], + [1, 3, 4, 5], + [1, 2, 4, 5], + [1, 2, 3, 5], + [1, 2, 3, 4 ]]) + +assert "f.rands" + (all (\x -> x >= 1.0 && x <= 2.0) (take 10 (f.rands 1.0 2.0))) + +assert "f.pureRand" + (let x := f.pureRand 1.0 2.0 in x >= 1.0 && x <= 2.0) diff --git a/test/lib/core/shell.egi b/test/lib/core/shell.egi new file mode 100644 --- /dev/null +++ b/test/lib/core/shell.egi @@ -0,0 +1,14 @@ +load "lib/core/shell.egi" + +assertEqual "TSV.parseLine" (TSV.parseLine [[2]] [] "1\t2\t3") (1, "2", "3") +assertEqual "TSV.parseLine" (TSV.parseLine [[2,2]] [] "1\t2\t3") (1, "2", 3) +assertEqual "TSV.parseLine" (TSV.parseLine [[2,1]] [] "1\t2\t3") (1, "2", "3") + +assertEqual "TSV.parseLine" (TSV.parseLine [] [[2]] "1\t2\t3") (1, [2, 3]) +assertEqual "TSV.parseLine" (TSV.parseLine [] [[2,2]] "1\t2\t3") (1, [2], 3) +assertEqual "TSV.parseLine" (TSV.parseLine [] [[2,1]] "1\t2\t3") (1, [2, 3]) + +-- TODO: Is this intended behavior? +assertEqual "TSV.parseLine" + (TSV.parseLine [[3,4], [6,9]] [[2,3], [5,7]] "1\t2\t3\t4\t5\t6\t7\t8\t9\t10") + (1, [2, "3"], "4", 5, ["6", "7", "8"], "9", 10) diff --git a/test/lib/core/sort.egi b/test/lib/core/sort.egi new file mode 100644 --- /dev/null +++ b/test/lib/core/sort.egi @@ -0,0 +1,11 @@ +assertEqual "sortWithSign" (sortWithSign []) (1, []) + +assertEqual "sortWithSign" (sortWithSign [[1]]) (1, [1]) + +assertEqual "sortWithSign" (sortWithSign [[2], [1]]) (-1, [1, 2]) +assertEqual "sortWithSign" (sortWithSign [[1], [2]]) (1, [1, 2]) +assertEqual "sortWithSign" (sortWithSign [[2, 3], [2, 1]]) (-1, [2, 1, 2, 3]) + +assertEqual "sortWithSign" (sortWithSign [[1], [3], [2]]) (-1, [1, 2, 3]) +assertEqual "sortWithSign" (sortWithSign [[3], [1], [2]]) (1, [1, 2, 3]) +assertEqual "sortWithSign" (sortWithSign [[3, 6], [1, 2], [2, 4]]) (1, [1, 2, 2, 4, 3, 6]) diff --git a/test/lib/math/tensor.egi b/test/lib/math/tensor.egi --- a/test/lib/math/tensor.egi +++ b/test/lib/math/tensor.egi @@ -51,7 +51,7 @@ assertEqual "append indices with ..." - (let A := generateTensor 2#1 [2, 2] + (let A := generateTensor (\_ -> 1) [2, 2] f %B := B..._j in f A_i) [|[|1, 1|], [|1, 1|]|]_i_j @@ -59,15 +59,9 @@ assertEqual "generate_tensor by using function expr" (let g_i_j := (generateTensor - (\n m -> if n = m then function (x, y, z) else 0) + (\match as list integer with + | [$n, #n] -> function (x, y, z) + | _ -> 0) [3, 3])_i_j in show (withSymbols [i, j] d/d g_i_j x)) "[| [| g_1_1|x, 0, 0 |], [| 0, g_2_2|x, 0 |], [| 0, 0, g_3_3|x |] |]" - -assertEqual - "define tensor having value of function expr" - (let h_i_j := [|[|function (x, y, z), 0, 0|] - , [|0, function (x, y, z), 0|] - , [|0, 0, function (x, y, z)|]|]_i_j - in show (withSymbols [i, j] d/d h_i_j x)) - "[| [| h_1_1|x, 0, 0 |], [| 0, h_2_2|x, 0 |], [| 0, 0, h_3_3|x |] |]"