diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs --- a/benchmark/Benchmark.hs +++ b/benchmark/Benchmark.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE FlexibleInstances #-} module Main where -import Control.Applicative ((<$>), (<*>)) -import Control.Applicative -import Control.DeepSeq (NFData (rnf)) -import Control.Monad.Except + import Criterion import Criterion.Main import Language.Egison -import Language.Egison.CmdOptions runEgisonFile :: String -> IO () -runEgisonFile path = initialEnv defaultOption >>= flip (loadEgisonFile defaultOption) path >> return () +runEgisonFile path = evalRuntimeT defaultOption $ do + env <- initialEnv + _ <- loadEgisonFile env path + return () main :: IO () main = defaultMainWith defaultConfig - [ bgroup "fact" [ bench "30000" $ nfIO $ runEgisonFile "benchmark/fact-30000.egi" ] + [ bgroup "fact" + [ bench "30000" $ nfIO $ runEgisonFile "benchmark/fact-30000.egi" ] , bgroup "collection" [ bench "cons-bench" $ nfIO $ runEgisonFile "benchmark/collection-bench-cons.egi" , bench "cons-bench-large" $ nfIO $ runEgisonFile "benchmark/collection-bench-cons-large.egi" diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 4.0.3 +Version: 4.1.0 Synopsis: Programming language with non-linear pattern-matching against non-free data Description: An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language. @@ -95,7 +95,8 @@ , hashable , optparse-applicative , prettyprinter - , mini-egison >= 1.0.0 + , unicode-show + , sweet-egison >= 0.1.0.2 if !impl(ghc > 8.0) Build-Depends: fail Hs-Source-Dirs: hs-src @@ -107,8 +108,17 @@ Language.Egison.Completion Language.Egison.Desugar Language.Egison.Data - Language.Egison.IState - Language.Egison.MathExpr + Language.Egison.Data.Collection + Language.Egison.Data.Utils + Language.Egison.EvalState + Language.Egison.Eval + Language.Egison.IExpr + Language.Egison.Match + Language.Egison.Math.Arith + Language.Egison.Math.Expr + Language.Egison.Math.Normalize + Language.Egison.Math.Rewrite + Language.Egison.Math Language.Egison.MathOutput Language.Egison.MList Language.Egison.Parser @@ -121,8 +131,13 @@ Language.Egison.PrettyMath.Mathematica Language.Egison.PrettyMath.Maxima Language.Egison.Primitives + Language.Egison.Primitives.Arith + Language.Egison.Primitives.IO + Language.Egison.Primitives.String + Language.Egison.Primitives.Types + Language.Egison.Primitives.Utils + Language.Egison.RState Language.Egison.Tensor - Language.Egison.Types Other-modules: Paths_egison autogen-modules: Paths_egison ghc-options: -O3 -Wall -Wno-name-shadowing -Wno-incomplete-patterns @@ -144,6 +159,7 @@ , filepath Other-modules: Paths_egison autogen-modules: Paths_egison + ghc-options: -Wall -Wno-name-shadowing Benchmark benchmark default-language: Haskell2010 @@ -153,12 +169,10 @@ Build-Depends: egison , base >= 4.0 && < 5 - , deepseq , criterion >= 0.5 - , transformers - , mtl Other-modules: Paths_egison autogen-modules: Paths_egison + ghc-options: -Wall -Wno-name-shadowing Executable egison default-language: Haskell2010 @@ -168,6 +182,7 @@ , base >= 4.0 && < 5 , array , containers + , exceptions , unordered-containers , haskeline , transformers 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,12 +1,11 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} module Main where -import Control.Exception (AsyncException (..), catch) +import Control.Exception (AsyncException (..)) +import Control.Monad.Catch (catch) import Control.Monad.Except -import Control.Monad.Trans.State +import Control.Monad.Reader import Data.List (intercalate) import qualified Data.Text as T @@ -22,13 +21,9 @@ import Text.Regex.TDFA ((=~)) import Language.Egison -import Language.Egison.CmdOptions import Language.Egison.Completion -import Language.Egison.Core (evalTopExpr', recursiveBind) -import Language.Egison.Desugar -import Language.Egison.MathOutput -import qualified Language.Egison.Parser.SExpr as SExpr -import qualified Language.Egison.Parser.NonS as NonS +import Language.Egison.Eval +import Language.Egison.Parser (parseTopExpr) import Options.Applicative @@ -36,7 +31,7 @@ main = execParser cmdParser >>= runWithOptions isInValidMathOption :: EgisonOpts -> Bool -isInValidMathOption EgisonOpts{ optMathExpr = Just lang } = notElem lang ["asciimath", "latex", "mathematica", "maxima"] +isInValidMathOption EgisonOpts{ optMathExpr = Just lang } = lang `notElem` ["asciimath", "latex", "mathematica", "maxima", "haskell"] isInValidMathOption EgisonOpts{ optMathExpr = Nothing } = False runWithOptions :: EgisonOpts -> IO () @@ -44,62 +39,77 @@ hPrint stderr (Default "this output lang is not supported") >> exitFailure runWithOptions EgisonOpts{ optShowVersion = True } = putStrLn (showVersion version) >> exitSuccess -runWithOptions opts = do - coreEnv <- initialEnv opts - mEnv <- evalEgisonTopExprs opts coreEnv $ map Load (optLoadLibs opts) ++ map LoadFile (optLoadFiles opts) +runWithOptions opts = evalRuntimeT opts run + +run :: RuntimeM () +run = do + opts <- ask + coreEnv <- initialEnv + mEnv <- fromEvalT $ evalTopExprs coreEnv $ map Load (optLoadLibs opts) ++ map LoadFile (optLoadFiles opts) case mEnv of - Left err -> print err - Right env -> - case opts of - -- Evaluate the given string - EgisonOpts { optEvalString = Just expr } - | optTsvOutput opts -> - executeEgisonTopExpr opts env $ "execute (each (\\x -> print (showTsv x)) (" ++ expr ++ "))" - | otherwise -> do - executeEgisonTopExpr opts env $ "execute (print (show (" ++ expr ++ ")))" - -- Execute the given string - EgisonOpts { optExecuteString = Just cmd } -> - executeEgisonTopExpr opts env $ "execute (" ++ cmd ++ ")" - -- Operate input in tsv format as infinite stream - EgisonOpts { optSubstituteString = Just sub } -> - let (sopts, copts) = unzip (optFieldInfo opts) - sopts' = "[" ++ intercalate ", " sopts ++ "]" - copts' = "[" ++ intercalate ", " copts ++ "]" - expr = "load \"lib/core/shell.egi\"\n" - ++ "execute (let SH.input := SH.genInput " ++ sopts' ++ " " ++ copts' ++ "\n" - ++ " in each (\\x -> print (" ++ if optTsvOutput opts then "showTsv" else "show" ++ " x)) (" ++ sub ++ " SH.input))" - in executeEgisonTopExpr opts env expr - -- Execute a script (test only) - EgisonOpts { optTestOnly = True, optExecFile = Just (file, _) } -> do - result <- if optNoIO opts - -- TODO: Switch parsers by file extension - then do input <- readFile file - runEgisonTopExprs opts env input - else evalEgisonTopExprs opts env [LoadFile file] - either print (const $ return ()) result - -- Execute a script from the main function - EgisonOpts { optExecFile = Just (file, args) } -> do - result <- evalEgisonTopExprs opts env [LoadFile file, Execute (ApplyExpr (stringToVarExpr "main") (CollectionExpr (map ((ElementExpr . StringExpr) . T.pack) args)))] - either print (const $ return ()) result - -- Start the read-eval-print-loop - _ -> do - when (optShowBanner opts) showBanner - repl opts env - when (optShowBanner opts) showByebyeMessage - exitSuccess + Left err -> liftIO $ print err + Right env -> handleOption env opts -executeEgisonTopExpr :: EgisonOpts -> Env -> String -> IO () -executeEgisonTopExpr opts env expr = do - cmdRet <- runEgisonTopExprs opts env expr +handleOption :: Env -> EgisonOpts -> RuntimeM () +handleOption env opts = + case opts of + -- Evaluate the given string + EgisonOpts { optEvalString = Just expr } -> + runAndPrintExpr env expr + -- Execute the given string + EgisonOpts { optExecuteString = Just cmd } -> + executeTopExpr env $ "execute (" ++ cmd ++ ")" + -- Operate input in tsv format as infinite stream + EgisonOpts { optSubstituteString = Just sub } -> + let (sopts, copts) = unzip (optFieldInfo opts) + sopts' = "[" ++ intercalate ", " sopts ++ "]" + copts' = "[" ++ intercalate ", " copts ++ "]" + expr = "load \"lib/core/shell.egi\"\n" + ++ "execute (let SH.input := SH.genInput " ++ sopts' ++ " " ++ copts' ++ "\n" + ++ if optTsvOutput opts then " in each (\\x -> print (showTsv x)) ((" ++ sub ++ ") SH.input))" + else " in each (\\x -> print (show x)) ((" ++ sub ++ ") SH.input))" + in executeTopExpr env expr + -- Execute a script (test only) + EgisonOpts { optTestOnly = True, optExecFile = Just (file, _) } -> do + exprs <- liftIO $ readFile file + result <- if optNoIO opts + then fromEvalT (runTopExprs env exprs) + else fromEvalT (evalTopExprs env [LoadFile file]) + liftIO $ either print (const $ return ()) result + -- Execute a script from the main function + EgisonOpts { optExecFile = Just (file, args) } -> do + result <- fromEvalT $ evalTopExprs env [LoadFile file, Execute (makeApply "main" (map (ConstantExpr . StringExpr . T.pack) args))] + liftIO $ either print (const $ return ()) result + EgisonOpts { optMapTsvInput = Just expr } -> + handleOption env (opts { optSubstituteString = Just $ "\\x -> map (" ++ expr ++ ") x" }) + EgisonOpts { optFilterTsvInput = Just expr } -> + handleOption env (opts { optSubstituteString = Just $ "\\x -> filter (" ++ expr ++ ") x" }) + -- Start the read-eval-print-loop + _ -> do + when (optShowBanner opts) (liftIO showBanner) + repl env + when (optShowBanner opts) (liftIO showByebyeMessage) + liftIO exitSuccess + +runAndPrintExpr :: Env -> String -> RuntimeM () +runAndPrintExpr env expr = do + isTsvOutput <- asks optTsvOutput + if isTsvOutput + then executeTopExpr env $ "execute (each (\\x -> print (showTsv x)) (" ++ expr ++ "))" + else executeTopExpr env $ "execute (print (show (" ++ expr ++ ")))" + +executeTopExpr :: Env -> String -> RuntimeM () +executeTopExpr env expr = do + cmdRet <- fromEvalT (runTopExprs env expr) case cmdRet of - Left err -> hPrint stderr err >> exitFailure - _ -> exitSuccess + Left err -> liftIO $ hPrint stderr err >> exitFailure + _ -> liftIO exitSuccess showBanner :: IO () showBanner = do putStrLn $ "Egison Version " ++ showVersion version - putStrLn $ "https://www.egison.org" - putStrLn $ "Welcome to Egison Interpreter!" + putStrLn "https://www.egison.org" + putStrLn "Welcome to Egison Interpreter!" -- putStrLn $ "** Information **" -- putStrLn $ "We can use the tab key to complete keywords on the interpreter." -- putStrLn $ "If we press the tab key after a closed parenthesis, the next closed parenthesis will be completed." @@ -108,69 +118,54 @@ showByebyeMessage :: IO () showByebyeMessage = putStrLn "Leaving Egison Interpreter." -repl :: EgisonOpts -> Env -> IO () -repl opts env = - loop $ StateT (\defines -> (, defines) <$> recursiveBind env defines) - where - settings :: MonadIO m => FilePath -> Settings m - settings home = setComplete completeEgison $ defaultSettings { historyFile = Just (home ".egison_history"), autoAddHistory = False } +settings :: MonadIO m => FilePath -> Env -> Settings m +settings home env = setComplete (completeEgison env) $ defaultSettings { historyFile = Just (home ".egison_history"), autoAddHistory = False } - loop :: StateT [(Var, EgisonExpr)] EvalM Env -> IO () - loop st = (do - home <- getHomeDirectory - input <- liftIO $ runInputT (settings home) $ getEgisonExpr opts - case (optNoIO opts, input) of - (_, Nothing) -> return () - (True, Just (LoadFile _)) -> do - putStrLn "error: No IO support" - loop st - (True, Just (Load _)) -> do - putStrLn "error: No IO support" - loop st - (_, Just topExpr) -> do - result <- liftIO $ fromEvalM (desugarTopExpr topExpr >>= evalTopExpr' opts st) - case result of - Left err -> liftIO (print err) >> loop st - Right (Nothing, st') -> loop st' - Right (Just output, st') -> - case optMathExpr opts of - Nothing -> putStrLn output >> loop st' - Just lang -> putStrLn (changeOutputInLang lang output) >> loop st' - ) - `catch` - (\case - UserInterrupt -> putStrLn "" >> loop st - StackOverflow -> putStrLn "Stack over flow!" >> loop st - HeapOverflow -> putStrLn "Heap over flow!" >> loop st - _ -> putStrLn "error!" >> loop st - ) +repl :: Env -> RuntimeM () +repl env = (do + home <- liftIO getHomeDirectory + input <- runInputT (settings home env) getEgisonExpr + case input of + Nothing -> return () + Just topExpr -> do + result <- fromEvalT (evalTopExprStr env topExpr) + case result of + Left err -> liftIO (print err) >> repl env + Right (Just str, env') -> liftIO (putStrLn str) >> repl env' + Right (Nothing, env') -> repl env' + ) + `catch` + (\case + UserInterrupt -> liftIO (putStrLn "") >> repl env + StackOverflow -> liftIO (putStrLn "Stack over flow!") >> repl env + HeapOverflow -> liftIO (putStrLn "Heap over flow!") >> repl env + _ -> liftIO (putStrLn "error!") >> repl env + ) -- |Get Egison expression from the prompt. We can handle multiline input. -getEgisonExpr :: EgisonOpts -> InputT IO (Maybe EgisonTopExpr) -getEgisonExpr opts = getEgisonExpr' opts "" +getEgisonExpr :: InputT RuntimeM (Maybe TopExpr) +getEgisonExpr = getEgisonExpr' "" where - getEgisonExpr' opts prev = do + getEgisonExpr' prev = do + opts <- lift ask mLine <- case prev of "" -> getInputLine $ optPrompt opts _ -> getInputLine $ replicate (length $ optPrompt opts) ' ' case mLine of Nothing -> return Nothing - Just [] -> - if null prev - then getEgisonExpr opts - else getEgisonExpr' opts prev + Just [] | null prev -> getEgisonExpr + Just [] -> getEgisonExpr' prev Just line -> do history <- getHistory putHistory $ addHistoryUnlessConsecutiveDupe line history let input = prev ++ line - let parsedExpr = if optSExpr opts then SExpr.parseTopExpr input - else NonS.parseTopExpr input + parsedExpr <- lift $ parseTopExpr input case parsedExpr of - Left err | show err =~ "unexpected end of input" -> - getEgisonExpr' opts $ input ++ "\n" + Left err | err =~ "unexpected end of input" -> + getEgisonExpr' (input ++ "\n") Left err -> do - liftIO $ print err - getEgisonExpr opts + liftIO $ putStrLn ("Parse error at: " ++ err) + getEgisonExpr Right topExpr -> do -- outputStr $ show topExpr return $ Just topExpr 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 @@ -1,5 +1,3 @@ -{-# LANGUAGE TupleSections #-} - {- | Module : Language.Egison Licence : MIT @@ -11,117 +9,64 @@ ( module Language.Egison.AST , module Language.Egison.Data , module Language.Egison.Primitives - -- * Eval Egison expressions - , evalTopExprs - , evalTopExpr - , evalEgisonExpr - , evalEgisonTopExpr - , evalEgisonTopExprs - , runEgisonExpr - , runEgisonTopExpr - , runEgisonTopExpr' - , runEgisonTopExprs - -- * Load Egison files - , loadEgisonLibrary - , loadEgisonFile + -- * Modules needed to execute Egison + , module Language.Egison.CmdOptions + , module Language.Egison.RState -- * Environment , initialEnv -- * Information , version ) where +import Control.Monad.Reader (asks, local) +import Control.Monad.State + import Data.Version import qualified Paths_egison as P import Language.Egison.AST import Language.Egison.CmdOptions -import Language.Egison.Core import Language.Egison.Data -import Language.Egison.MathOutput (changeOutputInLang) -import Language.Egison.Parser +import Language.Egison.Eval import Language.Egison.Primitives - -import Control.Monad.State +import Language.Egison.RState -- |Version number version :: Version version = P.version -evalTopExprs :: EgisonOpts -> Env -> [EgisonTopExpr] -> EvalM Env -evalTopExprs opts env exprs = do - (bindings, rest) <- collectDefs opts exprs [] [] - env <- recursiveBind env bindings - forM_ rest $ evalTopExpr opts env - return env - -evalTopExpr :: EgisonOpts -> Env -> EgisonTopExpr -> EvalM Env -evalTopExpr opts env topExpr = do - ret <- evalTopExpr' opts (StateT $ \defines -> (, defines) <$> recursiveBind env defines) topExpr - case fst ret of - Nothing -> return () - Just output -> liftIO $ - case optMathExpr opts of - Nothing -> putStrLn output - Just lang -> putStrLn $ changeOutputInLang lang output - evalStateT (snd ret) [] - --- |eval an Egison expression -evalEgisonExpr :: Env -> EgisonExpr -> IO (Either EgisonError EgisonValue) -evalEgisonExpr env expr = fromEvalM $ evalExprDeep env expr - --- |eval an Egison top expression -evalEgisonTopExpr :: EgisonOpts -> Env -> EgisonTopExpr -> IO (Either EgisonError Env) -evalEgisonTopExpr opts env exprs = fromEvalM $ evalTopExpr opts env exprs - --- |eval Egison top expressions -evalEgisonTopExprs :: EgisonOpts -> Env -> [EgisonTopExpr] -> IO (Either EgisonError Env) -evalEgisonTopExprs opts env exprs = fromEvalM $ evalTopExprs opts env exprs - --- |eval an Egison expression. Input is a Haskell string. -runEgisonExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError EgisonValue) -runEgisonExpr opts env input = - fromEvalM $ readExpr (optSExpr opts) input >>= evalExprDeep env - --- |eval an Egison top expression. Input is a Haskell string. -runEgisonTopExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError Env) -runEgisonTopExpr opts env input = - fromEvalM $ readTopExpr (optSExpr opts) input >>= evalTopExpr opts env - --- |eval an Egison top expression. Input is a Haskell string. -runEgisonTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EvalM Env -> String -> IO (Either EgisonError (Maybe String, StateT [(Var, EgisonExpr)] EvalM Env)) -runEgisonTopExpr' opts st input = - fromEvalM $ readTopExpr (optSExpr opts) input >>= evalTopExpr' opts st - --- |eval Egison top expressions. Input is a Haskell string. -runEgisonTopExprs :: EgisonOpts -> Env -> String -> IO (Either EgisonError Env) -runEgisonTopExprs opts env input = - fromEvalM $ readTopExprs (optSExpr opts) input >>= evalTopExprs opts env - --- |load an Egison file -loadEgisonFile :: EgisonOpts -> Env -> FilePath -> IO (Either EgisonError Env) -loadEgisonFile opts env path = evalEgisonTopExpr opts env (LoadFile path) - --- |load an Egison library -loadEgisonLibrary :: EgisonOpts -> Env -> FilePath -> IO (Either EgisonError Env) -loadEgisonLibrary opts env path = evalEgisonTopExpr opts env (Load path) - -- |Environment that contains core libraries -initialEnv :: EgisonOpts -> IO Env -initialEnv opts = do - env <- if optNoIO opts then primitiveEnvNoIO - else primitiveEnv - ret <- evalEgisonTopExprs defaultOption env $ map Load coreLibraries +initialEnv :: RuntimeM Env +initialEnv = do + isNoIO <- asks optNoIO + useMathNormalize <- asks optMathNormalize + env <- liftIO $ if isNoIO then primitiveEnvNoIO else primitiveEnv + let normalizeLib = if useMathNormalize then "lib/math/normalize.egi" else "lib/math/no-normalize.egi" + ret <- local (const defaultOption) + (fromEvalT (evalTopExprs env $ map Load (coreLibraries ++ [normalizeLib]))) case ret of Left err -> do - print . show $ err + liftIO $ print (show err) return env Right env' -> return env' coreLibraries :: [String] coreLibraries = - [ "lib/math/expression.egi" - , "lib/math/normalize.egi" - , "lib/math/common/arithmetic.egi" + -- Libs that defines user-defined infixes comes first + [ "lib/core/base.egi" -- Defines (&&) (||) + , "lib/math/common/arithmetic.egi" -- Defines (+) (-) (*) (/) (+') (-') (*') (/') + , "lib/math/algebra/tensor.egi" -- Defines (.) (.') + , "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" + , "lib/core/order.egi" + , "lib/core/random.egi" + , "lib/core/string.egi" + , "lib/core/sort.egi" , "lib/math/common/constants.egi" , "lib/math/common/functions.egi" , "lib/math/algebra/root.egi" @@ -131,15 +76,5 @@ , "lib/math/analysis/integral.egi" , "lib/math/algebra/vector.egi" , "lib/math/algebra/matrix.egi" - , "lib/math/algebra/tensor.egi" , "lib/math/geometry/differential-form.egi" - , "lib/core/assoc.egi" - , "lib/core/base.egi" - , "lib/core/collection.egi" - , "lib/core/io.egi" - , "lib/core/maybe.egi" - , "lib/core/number.egi" - , "lib/core/order.egi" - , "lib/core/random.egi" - , "lib/core/string.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,7 +1,5 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {- | Module : Language.Egison.AST @@ -11,320 +9,264 @@ -} module Language.Egison.AST - ( EgisonTopExpr (..) - , EgisonExpr (..) - , EgisonPattern (..) - , Var (..) + ( TopExpr (..) + , ConstantExpr (..) + , Expr (..) + , Pattern (..) , VarWithIndices (..) - , varToVarWithIndices + , makeApply , Arg (..) - , Index (..) - , extractIndex + , ArgPattern (..) + , IndexExpr (..) + , VarIndex (..) , PMMode (..) - , InnerExpr (..) - , BindingExpr + , BindingExpr (..) , MatchClause , PatternDef , LoopRange (..) , PrimitivePatPattern (..) - , PrimitiveDataPattern (..) - , Infix (..) - , BinOpAssoc (..) - , reservedExprInfix - , reservedPatternInfix + , PDPatternBase (..) + , PrimitiveDataPattern + , Op (..) + , Assoc (..) + , reservedExprOp + , reservedPatternOp , findOpFrom - , stringToVar - , stringToVarExpr + , stringToVarWithIndices ) where -import Data.Hashable (Hashable) -import Data.List (find, intercalate) +import Data.List (find) import Data.Maybe (fromJust) -import Data.List.Split (splitOn) import Data.Text (Text) -import GHC.Generics (Generic) -data EgisonTopExpr = - Define Var EgisonExpr - | DefineWithIndices VarWithIndices EgisonExpr - | Redefine Var EgisonExpr - | Test EgisonExpr - | Execute EgisonExpr +data TopExpr + = Define VarWithIndices Expr + | Test Expr + | Execute Expr -- temporary : we will replace load to import and export | LoadFile String | Load String - | InfixDecl Bool Infix -- True for pattern infix; False for expression infix - deriving (Show, Eq) + | InfixDecl Bool Op -- True for pattern infix; False for expression infix + deriving Show -data EgisonExpr = - CharExpr Char +data ConstantExpr + = CharExpr Char | StringExpr Text | BoolExpr Bool | IntegerExpr Integer | FloatExpr Double - | VarExpr Var + | SomethingExpr + | UndefinedExpr + deriving Show + +data Expr + = ConstantExpr ConstantExpr + | VarExpr String | FreshVarExpr - | IndexedExpr Bool EgisonExpr [Index EgisonExpr] -- True -> delete old index and append new one - | SubrefsExpr Bool EgisonExpr EgisonExpr - | SuprefsExpr Bool EgisonExpr EgisonExpr - | UserrefsExpr Bool EgisonExpr EgisonExpr - | PowerExpr EgisonExpr EgisonExpr -- TODO: delete this in v4.0.0 - | InductiveDataExpr String [EgisonExpr] - | TupleExpr [EgisonExpr] - | CollectionExpr [InnerExpr] -- TODO: InnerExpr should be EgisonExpr from v4.0.0 - | HashExpr [(EgisonExpr, EgisonExpr)] - | VectorExpr [EgisonExpr] + | IndexedExpr Bool Expr [IndexExpr Expr] -- True -> delete old index and append new one + | SubrefsExpr Bool Expr Expr + | SuprefsExpr Bool Expr Expr + | UserrefsExpr Bool Expr Expr + | TupleExpr [Expr] + | CollectionExpr [Expr] + | ConsExpr Expr Expr + | JoinExpr Expr Expr + | HashExpr [(Expr, Expr)] + | VectorExpr [Expr] - | LambdaExpr [Arg] EgisonExpr - | MemoizedLambdaExpr [String] EgisonExpr - | CambdaExpr String EgisonExpr - | PatternFunctionExpr [String] EgisonPattern + | LambdaExpr [Arg ArgPattern] Expr + | LambdaExpr' [Arg String] Expr + | MemoizedLambdaExpr [String] Expr + | CambdaExpr String Expr + | PatternFunctionExpr [String] Pattern - | IfExpr EgisonExpr EgisonExpr EgisonExpr - | LetRecExpr [BindingExpr] EgisonExpr - | LetExpr [BindingExpr] EgisonExpr - | LetStarExpr [BindingExpr] EgisonExpr - | WithSymbolsExpr [String] EgisonExpr + | IfExpr Expr Expr Expr + | LetExpr [BindingExpr] Expr + | LetRecExpr [BindingExpr] Expr + | WithSymbolsExpr [String] Expr - | MatchExpr PMMode EgisonExpr EgisonExpr [MatchClause] - | MatchAllExpr PMMode EgisonExpr EgisonExpr [MatchClause] - | MatchLambdaExpr EgisonExpr [MatchClause] - | MatchAllLambdaExpr EgisonExpr [MatchClause] + | MatchExpr PMMode Expr Expr [MatchClause] + | MatchAllExpr PMMode Expr Expr [MatchClause] + | MatchLambdaExpr Expr [MatchClause] + | MatchAllLambdaExpr Expr [MatchClause] | MatcherExpr [PatternDef] - | AlgebraicDataMatcherExpr [(String, [EgisonExpr])] + | AlgebraicDataMatcherExpr [(String, [Expr])] - | QuoteExpr EgisonExpr - | QuoteSymbolExpr EgisonExpr - | WedgeApplyExpr EgisonExpr EgisonExpr + | QuoteExpr Expr + | QuoteSymbolExpr Expr + | WedgeApplyExpr Expr [Expr] - | DoExpr [BindingExpr] EgisonExpr - | IoExpr EgisonExpr + | DoExpr [BindingExpr] Expr - | PrefixExpr String EgisonExpr - | InfixExpr Infix EgisonExpr EgisonExpr - | SectionExpr Infix (Maybe EgisonExpr) (Maybe EgisonExpr) -- There cannot be 'SectionExpr op (Just _) (Just _)' + | PrefixExpr String Expr + | InfixExpr Op Expr Expr + | SectionExpr Op (Maybe Expr) (Maybe Expr) -- There cannot be 'SectionExpr op (Just _) (Just _)' - | SeqExpr EgisonExpr EgisonExpr - | ApplyExpr EgisonExpr EgisonExpr - | CApplyExpr EgisonExpr EgisonExpr - | AnonParamFuncExpr Integer EgisonExpr + | SeqExpr Expr Expr + | ApplyExpr Expr [Expr] + | CApplyExpr Expr Expr + | AnonParamFuncExpr Integer Expr | AnonParamExpr Integer - | GenerateTensorExpr EgisonExpr EgisonExpr - | TensorExpr EgisonExpr EgisonExpr - | TensorContractExpr EgisonExpr - | TensorMapExpr EgisonExpr EgisonExpr - | TensorMap2Expr EgisonExpr EgisonExpr EgisonExpr - | TransposeExpr EgisonExpr EgisonExpr - | FlipIndicesExpr EgisonExpr -- Does not appear in user program + | GenerateTensorExpr Expr Expr + | TensorExpr Expr Expr + | TensorContractExpr Expr + | TensorMapExpr Expr Expr + | TensorMap2Expr Expr Expr Expr + | TransposeExpr Expr Expr + | FlipIndicesExpr Expr -- Does not appear in user program - | FunctionExpr [EgisonExpr] + | FunctionExpr [String] + deriving Show - | SomethingExpr - | UndefinedExpr - deriving (Eq, Show) +data VarWithIndices = VarWithIndices String [VarIndex] + deriving Show -data Var = Var [String] [Index ()] - deriving (Eq, Generic) +data Arg a + = ScalarArg a + | InvertedScalarArg a + | TensorArg a + deriving Show -data VarWithIndices = VarWithIndices [String] [Index String] - deriving (Eq) +data ArgPattern + = APWildCard + | APPatVar String + | APInductivePat String [Arg ArgPattern] + | APTuplePat [Arg ArgPattern] + | APEmptyPat + | APConsPat (Arg ArgPattern) (Arg ArgPattern) + | APSnocPat (Arg ArgPattern) (Arg ArgPattern) + deriving Show -data Arg = - ScalarArg String - | InvertedScalarArg String - | TensorArg String - deriving (Eq, Show) +data VarIndex + = VSubscript String + | VSuperscript String + | VGroupScripts [VarIndex] + | VSymmScripts [VarIndex] + | VAntiSymmScripts [VarIndex] + deriving Show -data Index a = - Subscript a +data IndexExpr a + = Subscript a | Superscript a | SupSubscript a | MultiSubscript a a | MultiSuperscript a a - | DFscript Integer Integer -- DifferentialForm | Userscript a - deriving (Eq, Functor, Foldable, Generic, Traversable) - -extractIndex :: Index a -> a -extractIndex (Subscript x) = x -extractIndex (Superscript x) = x -extractIndex (SupSubscript x) = x -extractIndex (Userscript x) = x -extractIndex _ = error "extractIndex: Not supported" - -data InnerExpr = - ElementExpr EgisonExpr - | SubCollectionExpr EgisonExpr - deriving (Show, Eq) + deriving (Show, Eq, Functor, Foldable, Traversable) data PMMode = BFSMode | DFSMode - deriving (Eq, Show) + deriving Show -type BindingExpr = ([Var], EgisonExpr) -type MatchClause = (EgisonPattern, EgisonExpr) -type PatternDef = (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) +data BindingExpr + = Bind PrimitiveDataPattern Expr + | BindWithIndices VarWithIndices Expr + deriving Show --- TODO(momohatt): AndPat and OrPat take only 2 arguments in new syntax -data EgisonPattern = - WildCard - | PatVar Var - | ValuePat EgisonExpr - | PredPat EgisonExpr - | IndexedPat EgisonPattern [EgisonExpr] - | LetPat [BindingExpr] EgisonPattern - | InfixPat Infix EgisonPattern EgisonPattern -- Includes AndPat,OrPat,InductivePat(cons/join) - | NotPat EgisonPattern - | AndPat [EgisonPattern] - | OrPat [EgisonPattern] - | ForallPat EgisonPattern EgisonPattern - | TuplePat [EgisonPattern] - | InductivePat String [EgisonPattern] - | LoopPat Var LoopRange EgisonPattern EgisonPattern +type MatchClause = (Pattern, Expr) +type PatternDef = (PrimitivePatPattern, Expr, [(PrimitiveDataPattern, Expr)]) + +data Pattern + = WildCard + | PatVar String + | ValuePat Expr + | PredPat Expr + | IndexedPat Pattern [Expr] + | LetPat [BindingExpr] Pattern + | InfixPat Op Pattern Pattern -- Includes AndPat,OrPat,InductivePat(cons/join) + | NotPat Pattern + | AndPat Pattern Pattern + | OrPat Pattern Pattern + | ForallPat Pattern Pattern + | TuplePat [Pattern] + | InductivePat String [Pattern] + | LoopPat String LoopRange Pattern Pattern | ContPat - | PApplyPat EgisonExpr [EgisonPattern] + | PApplyPat Expr [Pattern] | VarPat String - | InductiveOrPApplyPat String [EgisonPattern] + | InductiveOrPApplyPat String [Pattern] | SeqNilPat - | SeqConsPat EgisonPattern EgisonPattern + | SeqConsPat Pattern Pattern | LaterPatVar -- For symbolic computing - | DApplyPat EgisonPattern [EgisonPattern] - | DivPat EgisonPattern EgisonPattern - | PlusPat [EgisonPattern] - | MultPat [EgisonPattern] - | PowerPat EgisonPattern EgisonPattern - deriving (Eq, Show) + | DApplyPat Pattern [Pattern] + deriving Show -data LoopRange = LoopRange EgisonExpr EgisonExpr EgisonPattern - deriving (Eq, Show) +data LoopRange = LoopRange Expr Expr Pattern + deriving Show -data PrimitivePatPattern = - PPWildCard +data PrimitivePatPattern + = PPWildCard | PPPatVar | PPValuePat String | PPInductivePat String [PrimitivePatPattern] | PPTuplePat [PrimitivePatPattern] - deriving (Show, Eq) + deriving Show -data PrimitiveDataPattern = - PDWildCard - | PDPatVar String - | PDInductivePat String [PrimitiveDataPattern] - | PDTuplePat [PrimitiveDataPattern] +data PDPatternBase var + = PDWildCard + | PDPatVar var + | PDInductivePat String [PDPatternBase var] + | PDTuplePat [PDPatternBase var] | PDEmptyPat - | PDConsPat PrimitiveDataPattern PrimitiveDataPattern - | PDSnocPat PrimitiveDataPattern PrimitiveDataPattern - | PDConstantPat EgisonExpr - deriving (Show, Eq) + | PDConsPat (PDPatternBase var) (PDPatternBase var) + | PDSnocPat (PDPatternBase var) (PDPatternBase var) + | PDConstantPat ConstantExpr + deriving (Functor, Foldable, Show) -data Infix - = Infix { repr :: String -- syntastic representation - , func :: String -- semantics - , priority :: Int - , assoc :: BinOpAssoc - , isWedge :: Bool -- True if operator is prefixed with '!'. Only used for expression infix. - } +type PrimitiveDataPattern = PDPatternBase String + +data Op + = Op { repr :: String -- syntastic representation + , priority :: Int + , assoc :: Assoc + , isWedge :: Bool -- True if operator is prefixed with '!'. Only used for expression infix. + } deriving (Eq, Ord, Show) -data BinOpAssoc - = LeftAssoc - | RightAssoc - | NonAssoc +data Assoc + = InfixL + | InfixR + | InfixN + | Prefix deriving (Eq, Ord) -instance Show BinOpAssoc where - show LeftAssoc = "infixl" - show RightAssoc = "infixr" - show NonAssoc = "infix" +instance Show Assoc where + show InfixL = "infixl" + show InfixR = "infixr" + show InfixN = "infix" + show Prefix = "prefix" -reservedExprInfix :: [Infix] -reservedExprInfix = - [ makeInfix "^" "**" 8 LeftAssoc -- TODO: Make "**" into "^" when S-expr is deprecated - , makeInfix "^'" "**'" 8 LeftAssoc -- TODO: Make "**'" into "^'" when S-expr is deprecated - , makeInfix "*" "*" 7 LeftAssoc - , makeInfix "/" "/" 7 LeftAssoc - , makeInfix "*'" "*'" 7 LeftAssoc - , makeInfix "/'" "/'" 7 LeftAssoc - , makeInfix "." "." 7 LeftAssoc -- tensor multiplication - , makeInfix ".'" ".'" 7 LeftAssoc -- tensor multiplication - , makeInfix "%" "remainder" 7 LeftAssoc -- primitive function - , makeInfix "+" "+" 6 LeftAssoc - , makeInfix "-" "-" 6 LeftAssoc - , makeInfix "+'" "+'" 6 LeftAssoc - , makeInfix "-'" "-'" 6 LeftAssoc - , makeInfix "++" "append" 5 RightAssoc - , makeInfix "::" "cons" 5 RightAssoc - , makeInfix "=" "equal" 4 LeftAssoc -- primitive function - , makeInfix "<=" "lte" 4 LeftAssoc -- primitive function - , makeInfix ">=" "gte" 4 LeftAssoc -- primitive function - , makeInfix "<" "lt" 4 LeftAssoc -- primitive function - , makeInfix ">" "gt" 4 LeftAssoc -- primitive function - , makeInfix "&&" "&&" 3 RightAssoc - , makeInfix "||" "||" 2 RightAssoc - , makeInfix "$" "apply" 0 RightAssoc +reservedExprOp :: [Op] +reservedExprOp = + [ Op "!" 8 Prefix False -- Wedge + , Op "-" 7 Prefix False -- Negate + , Op "%" 7 InfixL False -- primitive function + , Op "*$" 7 Prefix False -- For InvertedScalarArg + , Op "*$" 7 InfixL False -- For InvertedScalarArg + , Op "++" 5 InfixR False + , Op "::" 5 InfixR False + , Op "=" 4 InfixL False -- primitive function + , Op "<=" 4 InfixL False -- primitive function + , Op ">=" 4 InfixL False -- primitive function + , Op "<" 4 InfixL False -- primitive function + , Op ">" 4 InfixL False -- primitive function ] - where - makeInfix r f p a = - Infix { repr = r, func = f, priority = p, assoc = a, isWedge = False } -reservedPatternInfix :: [Infix] -reservedPatternInfix = - [ makeInfix "^" "^" 8 LeftAssoc -- PowerPat - , makeInfix "*" "*" 7 LeftAssoc -- MultPat - , makeInfix "/" "div" 7 LeftAssoc -- DivPat - , makeInfix "+" "+" 6 LeftAssoc -- PlusPat - , makeInfix "::" "cons" 5 RightAssoc - , makeInfix "++" "join" 5 RightAssoc - , makeInfix "&" "&" 3 RightAssoc - , makeInfix "|" "|" 2 RightAssoc +reservedPatternOp :: [Op] +reservedPatternOp = + [ Op "::" 5 InfixR False -- cons (desugared) + , Op "++" 5 InfixR False -- join (desugared) + , Op "&" 3 InfixR False + , Op "|" 2 InfixR False ] - where - makeInfix r f p a = - Infix { repr = r, func = f, priority = p, assoc = a, isWedge = False } -findOpFrom :: String -> [Infix] -> Infix +findOpFrom :: String -> [Op] -> Op findOpFrom op table = fromJust $ find ((== op) . repr) table -instance Hashable (Index ()) -instance Hashable Var - -stringToVar :: String -> Var -stringToVar name = Var (splitOn "." name) [] - -stringToVarExpr :: String -> EgisonExpr -stringToVarExpr = VarExpr . stringToVar - -instance Show Var where - show (Var xs is) = intercalate "." xs ++ concatMap show is - -instance Show VarWithIndices where - show (VarWithIndices xs is) = intercalate "." xs ++ concatMap show is - -varToVarWithIndices :: Var -> VarWithIndices -varToVarWithIndices (Var xs is) = VarWithIndices xs $ map f is - where - f :: Index () -> Index String - f index = (\() -> "") <$> index - -instance Show (Index ()) where - show (Superscript ()) = "~" - show (Subscript ()) = "_" - show (SupSubscript ()) = "~_" - show (DFscript _ _) = "" - show (Userscript _) = "|" - -instance Show (Index String) where - show (Superscript s) = "~" ++ s - show (Subscript s) = "_" ++ s - show (SupSubscript s) = "~_" ++ s - show (DFscript _ _) = "" - show (Userscript i) = "|" ++ show i +stringToVarWithIndices :: String -> VarWithIndices +stringToVarWithIndices name = VarWithIndices name [] -instance Show (Index EgisonExpr) where - show (Superscript i) = "~" ++ show i - show (Subscript i) = "_" ++ show i - show (SupSubscript i) = "~_" ++ show i - show (DFscript _ _) = "" - show (Userscript i) = "|" ++ show i +makeApply :: String -> [Expr] -> Expr +makeApply func args = ApplyExpr (VarExpr func) args 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 @@ -12,6 +12,7 @@ ) where import Data.Char (isDigit) +import Data.List (intercalate) import Options.Applicative data EgisonOpts = EgisonOpts { @@ -31,11 +32,12 @@ optTestOnly :: Bool, optPrompt :: String, optMathExpr :: Maybe String, - optSExpr :: Bool + optSExpr :: Bool, + optMathNormalize :: Bool } defaultOption :: EgisonOpts -defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing False +defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing False True cmdParser :: ParserInfo EgisonOpts cmdParser = info (helper <*> cmdArgParser) @@ -79,12 +81,12 @@ <> long "substitute" <> metavar "EXPR" <> help "Operate input in tsv format as infinite stream")) - <*> optional ((\s -> "1#(map " ++ s ++ " %1)") <$> strOption + <*> optional (strOption (short 'm' <> long "map" <> metavar "EXPR" <> help "Operate input in tsv format line by line")) - <*> optional ((\s -> "1#(filter " ++ s ++ " %1)") <$> strOption + <*> optional (strOption (short 'f' <> long "filter" <> metavar "EXPR" @@ -118,18 +120,25 @@ (short 'S' <> long "sexpr-syntax" <> help "Use s-expression syntax") + <*> flag True False + (long "no-normalize" + <> help "Turn off normalization of math expressions") readFieldOption :: String -> (String, String) readFieldOption str = - let (s, rs) = span isDigit str in - case rs of - ',':rs' -> let (e, opts) = span isDigit rs' in - case opts of - ['s'] -> ("{" ++ s ++ " " ++ e ++ "}", "") - ['c'] -> ("{}", "{" ++ s ++ " " ++ e ++ "}") - ['s', 'c'] -> ("{" ++ s ++ " " ++ e ++ "}", "{" ++ s ++ " " ++ e ++ "}") - ['c', 's'] -> ("{" ++ s ++ " " ++ e ++ "}", "{" ++ s ++ " " ++ e ++ "}") - ['s'] -> ("{" ++ s ++ "}", "") - ['c'] -> ("", "{" ++ s ++ "}") - ['s', 'c'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}") - ['c', 's'] -> ("{" ++ s ++ "}", "{" ++ s ++ "}") + let (s, c) = readFieldOption' str in (f s, f c) + where + f x = "[" ++ intercalate ", " x ++ "]" + readFieldOption' str = + let (s, rs) = span isDigit str in + case rs of + ',':rs' -> let (e, opts) = span isDigit rs' in + case opts of + ['s'] -> ([s, e], []) + ['c'] -> ([], [s, e]) + ['s', 'c'] -> ([s, e], [s, e]) + ['c', 's'] -> ([s, e], [s, e]) + ['s'] -> ([s], []) + ['c'] -> ([], [s]) + ['s', 'c'] -> ([s], [s]) + ['c', 's'] -> ([s], [s]) 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 @@ -9,51 +9,39 @@ ( completeEgison ) where +import Data.HashMap.Strict (keys) import Data.List +import System.Console.Haskeline hiding (catch, handle, throwTo) -import System.Console.Haskeline hiding (catch, handle, throwTo) +import Language.Egison.Data (Env (..)) +import Language.Egison.IExpr (Var (..)) +import Language.Egison.Parser.NonS (upperReservedWords, lowerReservedWords) -- |Complete Egison keywords -completeEgison :: Monad m => CompletionFunc m -completeEgison arg@(')':_, _) = completeParen arg -completeEgison arg@('>':_, _) = completeParen arg -completeEgison arg@(']':_, _) = completeParen arg -completeEgison arg@('}':_, _) = completeParen arg -completeEgison arg@('(':_, _) = completeWord Nothing " \t<>[]{}$," completeAfterOpenParen arg -completeEgison arg@('<':_, _) = completeWord Nothing " \t()[]{}$," completeAfterOpenCons arg -completeEgison arg@(' ':_, _) = completeWord Nothing "" completeNothing arg -completeEgison arg@('[':_, _) = completeWord Nothing "" completeNothing arg -completeEgison arg@('{':_, _) = completeWord Nothing "" completeNothing arg -completeEgison arg@([], _) = completeWord Nothing "" completeNothing arg -completeEgison arg@(_, _) = completeWord Nothing " \t[]{}$," completeEgisonKeyword arg - -completeAfterOpenParen :: Monad m => String -> m [Completion] -completeAfterOpenParen str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) $ egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen - -completeAfterOpenCons :: Monad m => String -> m [Completion] -completeAfterOpenCons str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywordsAfterOpenCons +completeEgison :: Monad m => Env -> CompletionFunc m +completeEgison _ arg@(')':_, _) = completeParen arg +completeEgison _ arg@(']':_, _) = completeParen arg +completeEgison _ arg@('(':_, _) = completeWord Nothing "" completeNothing arg +completeEgison _ arg@(' ':_, _) = completeWord Nothing "" completeNothing arg +completeEgison _ arg@('[':_, _) = completeWord Nothing "" completeNothing arg +completeEgison _ arg@([], _) = completeWord Nothing "" completeNothing arg +completeEgison env arg = completeWord Nothing " \t[]{}$," (completeEgisonKeyword env) arg completeNothing :: Monad m => String -> m [Completion] completeNothing _ = return [] -completeEgisonKeyword :: Monad m => String -> m [Completion] -completeEgisonKeyword str = return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) egisonKeywords - -egisonPrimitivesAfterOpenParen :: [String] -egisonPrimitivesAfterOpenParen = map ((:) '(') ["+", "-", "*", "/", "numerator", "denominator", "modulo", "quotient", "remainder", "neg", "abs", "eq?", "lt?", "lte?", "gt?", "gte?", "round", "floor", "ceiling", "truncate", "sqrt", "exp", "log", "sin", "cos", "tan", "asin", "acos", "atan", "sinh", "cosh", "tanh", "asinh", "acosh", "atanh", "itof", "rtof", "stoi", "read", "show", "empty?", "uncons", "unsnoc", "assert", "assert-equal"] - -egisonKeywordsAfterOpenParen :: [String] -egisonKeywordsAfterOpenParen = map ((:) '(') ["define", "let", "letrec", "lambda", "match", "match-all", "match-lambda", "matcher", "algebraic-data-matcher", "pattern-function", "if", "loop", "io", "do"] - ++ ["id", "or", "and", "not", "char", "eq?/m", "compose", "compose3", "list", "map", "between", "repeat1", "repeat", "filter", "separate", "concat", "foldr", "foldl", "map2", "zip", "member?", "member?/m", "include?", "include?/m", "any", "all", "length", "count", "count/m", "car", "cdr", "rac", "rdc", "nth", "take", "drop", "while", "reverse", "multiset", "add", "add/m", "delete-first", "delete-first/m", "delete", "delete/m", "difference", "difference/m", "union", "union/m", "intersect", "intersect/m", "set", "unique", "unique/m", "print", "print-to-port", "each", "pure-rand", "fib", "fact", "divisor?", "gcd", "primes", "find-factor", "prime-factorization", "p-f", "min", "max", "min-and-max", "power", "mod", "sort", "intersperse", "intercalate", "split", "split/m"] - -egisonKeywordsAfterOpenCons :: [String] -egisonKeywordsAfterOpenCons = map ((:) '<') ["nil", "cons", "join", "snoc", "nioj"] - -egisonKeywordsInNeutral :: [String] -egisonKeywordsInNeutral = "something" : ["bool", "string", "integer", "nats", "primes"] +completeEgisonKeyword :: Monad m => Env -> String -> m [Completion] +completeEgisonKeyword (Env env _) str = do + let definedWords = filter f $ map (\(Var name _) -> name) $ concatMap keys env + return $ map (\kwd -> Completion kwd kwd False) $ filter (isPrefixOf str) (egisonKeywords ++ definedWords) + where + f [_] = False + f [_, '\''] = False + f ('b':'.':_) = False + f _ = True egisonKeywords :: [String] -egisonKeywords = egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral +egisonKeywords = upperReservedWords ++ lowerReservedWords completeParen :: Monad m => CompletionFunc m completeParen (lstr, _) = case closeParen lstr of @@ -82,15 +70,9 @@ closeParen' :: Integer -> String -> Maybe String closeParen' _ [] = Nothing closeParen' 0 ('(':_) = Just ")" -closeParen' 0 ('<':_) = Just ">" closeParen' 0 ('[':_) = Just "]" -closeParen' 0 ('{':_) = Just "}" closeParen' n ('(':str) = closeParen' (n - 1) str -closeParen' n ('<':str) = closeParen' (n - 1) str closeParen' n ('[':str) = closeParen' (n - 1) str -closeParen' n ('{':str) = closeParen' (n - 1) str closeParen' n (')':str) = closeParen' (n + 1) str -closeParen' n ('>':str) = closeParen' (n + 1) str closeParen' n (']':str) = closeParen' (n + 1) str -closeParen' n ('}':str) = closeParen' (n + 1) str closeParen' n (_:str) = closeParen' n str 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 @@ -11,1368 +11,1089 @@ -} module Language.Egison.Core - ( - -- * Egison code evaluation - collectDefs - , evalTopExpr' - , evalExpr - , evalExprDeep - , evalRef - , evalRefDeep - , evalWHNF - , applyFunc - -- * Environment - , recursiveBind - -- * Pattern matching - , patternMatch - -- * Tuple, Collection - , tupleToList - , collectionToList - ) where - -import Prelude hiding (mapM, mappend, mconcat) - -import Control.Arrow -import Control.Monad.Except (throwError) -import Control.Monad.State hiding (mapM, join) -import Control.Monad.Trans.Maybe - -import Data.Char (isUpper) -import Data.Foldable (toList) -import Data.IORef -import Data.List (partition) -import Data.Maybe -import Data.Sequence (Seq, ViewL (..), ViewR (..), (><)) -import qualified Data.Sequence as Sq -import Data.Traversable (mapM) - -import qualified Data.HashMap.Lazy as HL -import qualified Data.Vector as V - -import Language.Egison.AST -import Language.Egison.CmdOptions -import Language.Egison.Data -import Language.Egison.MList -import Language.Egison.IState (MonadEval(..)) -import Language.Egison.MathExpr -import Language.Egison.Parser -import Language.Egison.Pretty -import Language.Egison.Tensor - --- --- Evaluator --- - -collectDefs :: EgisonOpts -> [EgisonTopExpr] -> [(Var, EgisonExpr)] -> [EgisonTopExpr] -> EvalM ([(Var, EgisonExpr)], [EgisonTopExpr]) -collectDefs opts (expr:exprs) bindings rest = - case expr of - Define name expr -> collectDefs opts exprs ((name, expr) : bindings) rest - DefineWithIndices{} -> throwError =<< EgisonBug "should not reach here (desugared)" <$> getFuncNameStack - Redefine _ _ -> collectDefs opts exprs bindings $ if optTestOnly opts then expr : rest else rest - Test _ -> collectDefs opts exprs bindings $ if optTestOnly opts then expr : rest else rest - Execute _ -> collectDefs opts exprs bindings $ if optTestOnly opts then rest else expr : rest - LoadFile _ | optNoIO opts -> throwError (Default "No IO support") - LoadFile file -> do - exprs' <- loadFile file - collectDefs opts (exprs' ++ exprs) bindings rest - Load _ | optNoIO opts -> throwError (Default "No IO support") - Load file -> do - exprs' <- loadLibraryFile file - collectDefs opts (exprs' ++ exprs) bindings rest - InfixDecl{} -> collectDefs opts exprs bindings rest -collectDefs _ [] bindings rest = return (bindings, reverse rest) - -evalTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EvalM Env -> EgisonTopExpr -> EvalM (Maybe String, StateT [(Var, EgisonExpr)] EvalM Env) -evalTopExpr' _ st (Define name expr) = return (Nothing, withStateT (\defines -> (name, expr):defines) st) -evalTopExpr' _ _ DefineWithIndices{} = throwError =<< EgisonBug "should not reach here (desugared)" <$> getFuncNameStack -evalTopExpr' _ st (Redefine name expr) = return (Nothing, mapStateT (>>= \(env, defines) -> (, defines) <$> recursiveRebind env (name, expr)) st) -evalTopExpr' opts st (Test expr) = do - pushFuncName "" - val <- evalStateT st [] >>= flip evalExprDeep expr - popFuncName - case (optSExpr opts, optMathExpr opts) of - (False, Nothing) -> return (Just (show val), st) - _ -> return (Just (prettyS val), st) -evalTopExpr' _ st (Execute expr) = do - pushFuncName "" - io <- evalStateT st [] >>= flip evalExpr expr - case io of - Value (IOFunc m) -> m >> popFuncName >> return (Nothing, st) - _ -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack -evalTopExpr' opts st (Load file) = do - exprs <- loadLibraryFile file - (bindings, _) <- collectDefs opts exprs [] [] - return (Nothing, withStateT (\defines -> bindings ++ defines) st) -evalTopExpr' opts st (LoadFile file) = do - exprs <- loadFile file - (bindings, _) <- collectDefs opts exprs [] [] - return (Nothing, withStateT (\defines -> bindings ++ defines) st) -evalTopExpr' _ st InfixDecl{} = return (Nothing, st) - -evalExpr :: Env -> EgisonExpr -> EvalM WHNFData -evalExpr _ (CharExpr c) = return . Value $ Char c -evalExpr _ (StringExpr s) = return . Value $ toEgison s -evalExpr _ (BoolExpr b) = return . Value $ Bool b -evalExpr _ (IntegerExpr x) = return . Value $ toEgison x -evalExpr _ (FloatExpr x) = return . Value $ Float x - -evalExpr env (QuoteExpr expr) = do - whnf <- evalExpr env expr - case whnf of - Value (ScalarData s) -> return . Value $ ScalarData $ SingleTerm 1 [(Quote s, 1)] - _ -> throwError =<< TypeMismatch "scalar in quote" whnf <$> getFuncNameStack - -evalExpr env (QuoteSymbolExpr expr) = do - whnf <- evalExpr env expr - case whnf of - Value fn@(Func (Just _) _ _ _) -> return . Value $ symbolScalarData "" (prettyS fn) - Value (ScalarData _) -> return whnf - _ -> throwError =<< TypeMismatch "value in quote-function" whnf <$> getFuncNameStack - -evalExpr env (VarExpr var@(Var [name@(c:_)] [])) | isUpper c = refVar' env var >>= evalRef - where - refVar' :: Env -> Var -> EvalM ObjectRef - refVar' env var = maybe (newEvaluatedObjectRef (Value (InductiveData name []))) return - (refVar env var) - -evalExpr env (VarExpr name) = refVar' env name >>= evalRef - where - refVar' :: Env -> Var -> EvalM ObjectRef - refVar' env var = maybe (newEvaluatedObjectRef (Value (symbolScalarData "" $ prettyStr var))) return - (refVar env var) - -evalExpr env (AnonParamExpr n) = evalExpr env (stringToVarExpr ("::" ++ show n)) - -evalExpr _ (InductiveDataExpr name []) = return . Value $ InductiveData name [] -evalExpr env (InductiveDataExpr name exprs) = - Intermediate . IInductiveData name <$> mapM (newObjectRef env) exprs - -evalExpr _ (TupleExpr []) = return . Value $ Tuple [] -evalExpr env (TupleExpr [expr]) = evalExpr env expr -evalExpr env (TupleExpr exprs) = Intermediate . ITuple <$> mapM (newObjectRef env) exprs - -evalExpr _ (CollectionExpr []) = return . Value $ Collection Sq.empty - -evalExpr env (CollectionExpr inners) = do - inners' <- mapM fromInnerExpr inners - innersSeq <- liftIO $ newIORef $ Sq.fromList inners' - return $ Intermediate $ ICollection innersSeq - where - fromInnerExpr :: InnerExpr -> EvalM Inner - fromInnerExpr (ElementExpr expr) = IElement <$> newObjectRef env expr - fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newObjectRef env expr - -evalExpr env@(Env frame maybe_vwi) (VectorExpr exprs) = do - let n = toInteger (length exprs) - let indices = [1 .. (n + 1)] - whnfs <- zipWithM evalWithIndex exprs indices - case whnfs of - Intermediate (ITensor Tensor{}):_ -> - mapM toTensor (zipWith f whnfs indices) >>= tConcat' >>= fromTensor - _ -> fromTensor (Tensor [n] (V.fromList whnfs) []) - where - evalWithIndex :: EgisonExpr -> Integer -> EvalM WHNFData - evalWithIndex expr index = evalExpr env' expr - where - env' = case maybe_vwi of - Nothing -> env - Just (VarWithIndices name indices) -> - Env frame (Just (VarWithIndices name (zipWith changeIndex indices [toEgison index]))) - f (Intermediate (ITensor (Tensor ns xs indices))) i = - Intermediate (ITensor (Tensor ns xs' indices)) - where - xs' = V.fromList $ zipWith g (V.toList xs) $ map (\ms -> map toEgison (i:ms)) $ enumTensorIndices ns - f x _ = 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 (VarWithIndices name indices) -> - symbolScalarData' "" $ prettyStr (VarWithIndices name (zipWith changeIndex indices ms)) - g x _ = x - -evalExpr env (TensorExpr nsExpr xsExpr) = do - nsWhnf <- evalExpr env nsExpr - ns <- (fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EvalM [Integer] - xsWhnf <- evalExpr env xsExpr - xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef - if product ns == toInteger (length xs) - then fromTensor (initTensor ns xs) - else throwError =<< InconsistentTensorShape <$> getFuncNameStack - -evalExpr env (HashExpr assocs) = do - let (keyExprs, exprs) = unzip assocs - keyWhnfs <- mapM (evalExpr env) keyExprs - keys <- mapM makeHashKey keyWhnfs - refs <- mapM (newObjectRef env) exprs - case keys of - CharKey _ : _ -> do - let keys' = map (\case CharKey c -> c) keys - return . Intermediate . ICharHash $ HL.fromList $ zip keys' refs - StrKey _ : _ -> do - let keys' = map (\case StrKey s -> s) keys - return . Intermediate . IStrHash $ HL.fromList $ zip keys' refs - _ -> do - let keys' = map (\case IntKey i -> i) keys - return . Intermediate . IIntHash $ HL.fromList $ zip keys' refs - where - makeHashKey :: WHNFData -> EvalM EgisonHashKey - makeHashKey (Value val) = - case val of - 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 - -evalExpr env (IndexedExpr override expr indices) = do - tensor <- case expr of - VarExpr (Var xs is) -> do - let mObjRef = refVar env (Var xs $ is ++ map (const () <$>) indices) - case mObjRef of - Just objRef -> evalRef objRef - Nothing -> evalExpr env expr - _ -> evalExpr env expr - js <- mapM evalIndex indices - ret <- case tensor of - Value (ScalarData (SingleTerm 1 [(Symbol id name [], 1)])) -> do - js2 <- mapM evalIndexToScalar indices - return $ Value (ScalarData (SingleTerm 1 [(Symbol id name js2, 1)])) - 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 (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t - Intermediate (ITensor t@Tensor{}) -> refTensorWithOverride override js t - _ -> do - js2 <- mapM evalIndexToScalar indices - refArray tensor (map (ScalarData . extractIndex) js2) - return ret -- TODO: refactor - where - evalIndex :: Index EgisonExpr -> EvalM (Index EgisonValue) - evalIndex index = traverse (evalExprDeep env) index - - evalIndexToScalar :: Index EgisonExpr -> EvalM (Index ScalarData) - evalIndexToScalar index = traverse ((extractScalar =<<) . evalExprDeep env) index - -evalExpr env (SubrefsExpr override expr jsExpr) = do - js <- map Subscript <$> (evalExpr env jsExpr >>= collectionToList) - tensor <- case expr of - VarExpr (Var xs is) -> do - let mObjRef = refVar env (Var xs $ is ++ replicate (length js) (Subscript ())) - case mObjRef of - Just objRef -> evalRef objRef - Nothing -> evalExpr env expr - _ -> evalExpr env expr - case tensor of - Value (ScalarData _) -> return tensor - Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t - Intermediate (ITensor t@Tensor{}) -> refTensorWithOverride override js t - _ -> throwError =<< NotImplemented "subrefs" <$> getFuncNameStack - -evalExpr env (SuprefsExpr override expr jsExpr) = do - js <- map Superscript <$> (evalExpr env jsExpr >>= collectionToList) - tensor <- case expr of - VarExpr (Var xs is) -> do - let mObjRef = refVar env (Var xs $ is ++ replicate (length js) (Superscript ())) - case mObjRef of - Just objRef -> evalRef objRef - Nothing -> evalExpr env expr - _ -> evalExpr env expr - case tensor of - Value (ScalarData _) -> return tensor - Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t - Intermediate (ITensor t@Tensor{}) -> refTensorWithOverride override js t - _ -> throwError =<< NotImplemented "suprefs" <$> getFuncNameStack - -evalExpr env (UserrefsExpr _ expr jsExpr) = do - val <- evalExprDeep env expr - js <- map Userscript <$> (evalExpr env jsExpr >>= collectionToList >>= mapM extractScalar) - 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 - -evalExpr env (LambdaExpr names expr) = do - names' <- mapM (\case - TensorArg name' -> return name' - ScalarArg _ -> throwError =<< EgisonBug "scalar-arg remained" <$> getFuncNameStack) names - return . Value $ Func Nothing env names' expr - -evalExpr env (AnonParamFuncExpr n expr) = return . Value $ AnonParamFunc env n expr - -evalExpr env (CambdaExpr name expr) = return . Value $ CFunc Nothing env name expr - -evalExpr env (PatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern - -evalExpr (Env _ Nothing) (FunctionExpr _) = throwError $ Default "function symbol is not bound to a variable" - -evalExpr env@(Env _ (Just name)) (FunctionExpr args) = do - args' <- mapM (evalExprDeep env) args >>= mapM extractScalar - return . Value $ ScalarData (SingleTerm 1 [(FunctionData (symbolScalarData' "" (prettyStr name)) (map (symbolScalarData' "" . prettyStr') args) args' [], 1)]) - -evalExpr env (IfExpr test expr expr') = do - test <- evalExpr env test >>= fromWHNF - evalExpr env $ if test then expr else expr' - -evalExpr env (LetExpr bindings expr) = - mapM extractBindings bindings >>= flip evalExpr expr . extendEnv env . concat - where - extractBindings :: BindingExpr -> EvalM [Binding] - extractBindings ([name], expr) = - case expr of - FunctionExpr _ -> - let Env frame _ = env - in makeBindings [name] . (:[]) <$> newObjectRef (Env frame (Just $ varToVarWithIndices name)) expr - _ -> makeBindings [name] . (:[]) <$> newObjectRef env expr - extractBindings (names, expr) = - makeBindings names <$> (evalExpr env expr >>= fromTuple) - -evalExpr env (LetRecExpr bindings expr) = - let bindings' = evalState (concat <$> mapM extractBindings bindings) 0 - in recursiveBind env bindings' >>= flip evalExpr expr - where - extractBindings :: BindingExpr -> State Int [(Var, EgisonExpr)] - extractBindings ([name], expr) = return [(name, expr)] - extractBindings (names, expr) = do - var <- genVar - let k = length names - target = VarExpr var - matcher = TupleExpr $ replicate k SomethingExpr - nth n = - let pattern = TuplePat $ flip map [1..k] $ \i -> - if i == n then PatVar (stringToVar "#_") else WildCard - in MatchExpr BFSMode target matcher [(pattern, stringToVarExpr "#_")] - return ((var, expr) : map (second nth) (zip names [1..])) - - genVar :: State Int Var - genVar = modify (1+) >> gets (stringToVar . ('#':) . show) - -evalExpr env (TransposeExpr vars expr) = do - syms <- evalExpr env vars >>= collectionToList - whnf <- evalExpr env expr - case whnf of - Intermediate (ITensor t) -> Intermediate . ITensor <$> tTranspose' syms t - Value (TensorData t) -> Value . TensorData <$> tTranspose' syms t - _ -> return whnf - -evalExpr env (FlipIndicesExpr expr) = do - whnf <- evalExpr env expr - case whnf of - Intermediate (ITensor t) -> Intermediate . ITensor <$> tFlipIndices t - Value (TensorData t) -> Value . TensorData <$> tFlipIndices t - _ -> return whnf - -evalExpr env (WithSymbolsExpr vars expr) = do - symId <- fresh - syms <- mapM (newEvaluatedObjectRef . Value . symbolScalarData symId) vars - let bindings = zip (map stringToVar vars) syms - whnf <- evalExpr (extendEnv env bindings) expr - case whnf of - Value (TensorData t@Tensor{}) -> - Value . TensorData <$> removeTmpScripts symId t - Intermediate (ITensor t@Tensor{}) -> - Intermediate . ITensor <$> removeTmpScripts symId t - _ -> return whnf - where - isTmpSymbol :: String -> Index EgisonValue -> Bool - isTmpSymbol symId (Subscript (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id - isTmpSymbol symId (Superscript (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id - isTmpSymbol symId (SupSubscript (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id - isTmpSymbol symId (Userscript (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id - removeTmpScripts :: HasTensor a => String -> Tensor a -> EvalM (Tensor a) - removeTmpScripts symId (Tensor s xs is) = do - let (ds, js) = partition (isTmpSymbol symId) is - Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is) - return (Tensor s ys js) - - -evalExpr env (DoExpr bindings expr) = return $ Value $ IOFunc $ do - let body = foldr genLet (ApplyExpr expr $ TupleExpr [stringToVarExpr "#1"]) bindings - applyFunc env (Value $ Func Nothing env ["#1"] body) $ Value World - where - genLet (names, expr) expr' = - LetExpr [(map stringToVar ["#1", "#2"], ApplyExpr expr $ TupleExpr [stringToVarExpr "#1"])] $ - LetExpr [(names, stringToVarExpr "#2")] expr' - -evalExpr env (IoExpr expr) = do - io <- evalExpr env expr - case io of - Value (IOFunc m) -> do - val <- m >>= evalWHNF - case val of - Tuple [_, val'] -> return $ Value val' - _ -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack - -evalExpr env (MatchAllExpr pmmode target matcher clauses) = do - target <- evalExpr env target - matcher <- evalExpr env matcher >>= evalMatcherWHNF - f matcher target >>= fromMList - where - fromMList :: MList EvalM WHNFData -> EvalM WHNFData - fromMList MNil = return . Value $ Collection Sq.empty - fromMList (MCons val m) = do - head <- IElement <$> newEvaluatedObjectRef val - tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList) - seqRef <- liftIO . newIORef $ Sq.fromList [head, tail] - return . Intermediate $ ICollection seqRef - f matcher target = do - let tryMatchClause (pattern, expr) results = do - result <- patternMatch pmmode env pattern target matcher - mmap (flip evalExpr expr . extendEnv env) result >>= (`mappend` results) - mfoldr tryMatchClause (return MNil) (fromList clauses) - -evalExpr env (MatchExpr pmmode target matcher clauses) = do - target <- evalExpr env target - matcher <- evalExpr env matcher >>= evalMatcherWHNF - f matcher target - where - f matcher target = do - let tryMatchClause (pattern, expr) cont = do - result <- patternMatch pmmode env pattern target matcher - case result of - MCons bindings _ -> evalExpr (extendEnv env bindings) expr - MNil -> cont - currentFuncName <- topFuncName - callstack <- getFuncNameStack - foldr tryMatchClause (throwError $ MatchFailure currentFuncName callstack) clauses - -evalExpr env (SeqExpr expr1 expr2) = do - _ <- evalExprDeep env expr1 - evalExpr env expr2 - -evalExpr env (CApplyExpr func arg) = do - func <- evalExpr env func - args <- evalExpr env arg >>= collectionToList - case func of - Value (MemoizedFunc name ref hashRef env names body) -> do - indices' <- mapM fromEgison args - hash <- liftIO $ readIORef hashRef - case HL.lookup indices' hash of - Just objRef -> - evalRef objRef - Nothing -> do - whnf <- applyFunc env (Value (Func Nothing env names body)) (Value (makeTuple args)) - retRef <- newEvaluatedObjectRef whnf - hash <- liftIO $ readIORef hashRef - liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) - writeObjectRef ref (Value (MemoizedFunc name ref hashRef env names body)) - return whnf - _ -> applyFunc env func (Value (makeTuple args)) - -evalExpr env (ApplyExpr func arg) = do - func <- evalExpr env func >>= appendDFscripts 0 - case func of --- Value (ScalarData (SingleTerm 1 [(Symbol "" name@(c:_) [], 1)])) | isUpper c -> - Value (InductiveData name []) -> - case arg of - TupleExpr exprs -> - Intermediate . IInductiveData name <$> mapM (newObjectRef env) exprs - _ -> throwError $ Default "argument is not a tuple" - Value (TensorData t@Tensor{}) -> do - arg <- evalExpr env arg - Value <$> (tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor) >>= removeDFscripts - Intermediate (ITensor t@Tensor{}) -> do - arg <- evalExpr env arg - tMap (\f -> applyFunc env f arg) t >>= fromTensor - Value (MemoizedFunc name ref hashRef env' names body) -> do - arg <- evalExpr env arg - indices <- evalWHNF arg - indices' <- mapM fromEgison $ fromTupleValue indices - hash <- liftIO $ readIORef hashRef - case HL.lookup indices' hash of - Just objRef -> - evalRef objRef - Nothing -> do - whnf <- applyFunc env' (Value (Func Nothing env' names body)) arg - retRef <- newEvaluatedObjectRef whnf - hash <- liftIO $ readIORef hashRef - liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) - writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body)) - return whnf - _ -> do - arg <- evalExpr env arg - applyFunc env func arg >>= removeDFscripts - -evalExpr env (WedgeApplyExpr func arg) = do - func <- evalExpr env func >>= appendDFscripts 0 - arg <- evalExpr env arg >>= fromTupleWHNF - let k = fromIntegral (length arg) - arg <- zipWithM appendDFscripts [1..k] arg >>= makeITuple - case func of - Value (TensorData t@Tensor{}) -> - Value <$> (tMap (\f -> applyFunc env (Value f) arg >>= evalWHNF) t >>= fromTensor) - Intermediate (ITensor t@Tensor{}) -> - tMap (\f -> applyFunc env f arg) t >>= fromTensor - Value (MemoizedFunc name ref hashRef env names body) -> do - indices <- evalWHNF arg - indices' <- mapM fromEgison $ fromTupleValue indices - hash <- liftIO $ readIORef hashRef - case HL.lookup indices' hash of - Just objRef -> - evalRef objRef - Nothing -> do - whnf <- applyFunc env (Value (Func Nothing env names body)) arg - retRef <- newEvaluatedObjectRef whnf - hash <- liftIO $ readIORef hashRef - liftIO $ writeIORef hashRef (HL.insert indices' retRef hash) - writeObjectRef ref (Value (MemoizedFunc name ref hashRef env names body)) - return whnf - _ -> applyFunc env func arg >>= removeDFscripts - -evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env info - -evalExpr env (GenerateTensorExpr fnExpr shapeExpr) = do - shape <- evalExpr env shapeExpr >>= collectionToList - ns <- mapM fromEgison shape :: EvalM Shape - xs <- mapM (indexToWHNF env . map toEgison) (enumTensorIndices ns) - fromTensor (Tensor ns (V.fromList xs) []) - where - indexToWHNF :: Env -> [EgisonValue] {- index -} -> EvalM WHNFData - indexToWHNF (Env frame maybe_vwi) ms = do - let env' = maybe env (\(VarWithIndices name indices) -> Env frame $ Just $ VarWithIndices name $ zipWith changeIndex indices ms) maybe_vwi - fn <- evalExpr env' fnExpr - applyFunc env fn $ Value $ makeTuple ms - -evalExpr env (TensorContractExpr tExpr) = do - whnf <- evalExpr env tExpr - case whnf of - Intermediate (ITensor t@Tensor{}) -> do - ts <- tContract t - makeICollection (map tensorToWHNF ts) - Value (TensorData t@Tensor{}) -> do - ts <- tContract t - return $ Value $ Collection $ Sq.fromList $ map tensorToValue ts - _ -> makeICollection [whnf] - -evalExpr env (TensorMapExpr fnExpr tExpr) = do - fn <- evalExpr env fnExpr - whnf <- evalExpr env tExpr - case whnf of - Intermediate (ITensor t) -> - tMap (applyFunc env fn) t >>= fromTensor - Value (TensorData t) -> - Value <$> (tMap (applyFunc' env fn) t >>= fromTensor) - _ -> applyFunc env fn whnf - where - applyFunc' :: Env -> WHNFData -> EgisonValue -> EvalM EgisonValue - applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF - -evalExpr env (TensorMap2Expr fnExpr t1Expr t2Expr) = do - fn <- evalExpr env fnExpr - whnf1 <- evalExpr env t1Expr - whnf2 <- evalExpr env t2Expr - case (whnf1, whnf2) of - -- both of arguments are tensors - (Intermediate (ITensor t1), Intermediate (ITensor t2)) -> - tMap2 (applyFunc'' env fn) t1 t2 >>= fromTensor - (Intermediate (ITensor t), Value (TensorData (Tensor ns xs js))) -> do - let xs' = V.map Value xs - tMap2 (applyFunc'' env fn) t (Tensor ns xs' js) >>= fromTensor - (Value (TensorData (Tensor ns xs js)), Intermediate (ITensor t)) -> do - let xs' = V.map Value xs - tMap2 (applyFunc'' env fn) (Tensor ns xs' js) t >>= fromTensor - (Value (TensorData t1), Value (TensorData t2)) -> - Value <$> (tMap2 (\x y -> applyFunc' env fn (Tuple [x, y])) t1 t2 >>= fromTensor) - -- an argument is scalar - (Intermediate (ITensor (Tensor ns xs js)), whnf) -> do - ys <- V.mapM (\x -> applyFunc'' env fn x whnf) xs - return $ Intermediate (ITensor (Tensor ns ys js)) - (whnf, Intermediate (ITensor (Tensor ns xs js))) -> do - ys <- V.mapM (applyFunc'' env fn whnf) xs - return $ Intermediate (ITensor (Tensor ns ys js)) - (Value (TensorData (Tensor ns xs js)), whnf) -> do - ys <- V.mapM (\x -> applyFunc'' env fn (Value x) whnf) xs - return $ Intermediate (ITensor (Tensor ns ys js)) - (whnf, Value (TensorData (Tensor ns xs js))) -> do - ys <- V.mapM (applyFunc'' env fn whnf . Value) xs - return $ Intermediate (ITensor (Tensor ns ys js)) - _ -> applyFunc'' env fn whnf1 whnf2 - where - applyFunc' :: Env -> WHNFData -> EgisonValue -> EvalM EgisonValue - applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF - applyFunc'' :: Env -> WHNFData -> WHNFData -> WHNFData -> EvalM WHNFData - applyFunc'' env fn x y = do - xRef <- newEvaluatedObjectRef x - yRef <- newEvaluatedObjectRef y - applyFunc env fn (Intermediate (ITuple [xRef, yRef])) - - -evalExpr _ SomethingExpr = return $ Value Something -evalExpr _ UndefinedExpr = return $ Value Undefined -evalExpr _ expr = throwError =<< NotImplemented ("evalExpr for " ++ show expr) <$> getFuncNameStack - -evalExprDeep :: Env -> EgisonExpr -> EvalM EgisonValue -evalExprDeep env expr = evalExpr env expr >>= evalWHNF - -evalRef :: ObjectRef -> EvalM WHNFData -evalRef ref = do - obj <- liftIO $ readIORef ref - case obj of - WHNF val -> return val - Thunk thunk -> do - val <- thunk - writeObjectRef ref val - return val - -evalRefDeep :: ObjectRef -> EvalM EgisonValue -evalRefDeep ref = do - obj <- liftIO $ readIORef ref - case obj of - WHNF (Value val) -> return val - WHNF val -> do - val <- evalWHNF val - writeObjectRef ref $ Value val - return val - Thunk thunk -> do - val <- thunk >>= evalWHNF - writeObjectRef ref $ Value val - return val - -evalWHNF :: WHNFData -> EvalM EgisonValue -evalWHNF (Value val) = return val -evalWHNF (Intermediate (IInductiveData name refs)) = - InductiveData name <$> mapM evalRefDeep refs -evalWHNF (Intermediate (IIntHash refs)) = do - refs' <- mapM evalRefDeep refs - return $ IntHash refs' -evalWHNF (Intermediate (ICharHash refs)) = do - refs' <- mapM evalRefDeep refs - return $ CharHash refs' -evalWHNF (Intermediate (IStrHash refs)) = do - refs' <- mapM evalRefDeep refs - return $ StrHash refs' -evalWHNF (Intermediate (ITuple [ref])) = evalRefDeep ref -evalWHNF (Intermediate (ITuple refs)) = Tuple <$> mapM evalRefDeep refs -evalWHNF (Intermediate (ITensor (Tensor ns whnfs js))) = do - vals <- mapM evalWHNF (V.toList whnfs) - return $ TensorData $ Tensor ns (V.fromList vals) js -evalWHNF coll = Collection <$> (fromCollection coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList) - -addscript :: (Index EgisonValue, Tensor a) -> Tensor a -addscript (subj, Tensor s t i) = Tensor s t (i ++ [subj]) - -valuetoTensor2 :: WHNFData -> Tensor WHNFData -valuetoTensor2 (Intermediate (ITensor t)) = t - -applyFunc :: Env -> WHNFData -> WHNFData -> EvalM WHNFData -applyFunc env (Value (TensorData (Tensor s1 t1 i1))) tds = do - tds <- fromTupleWHNF tds - if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s _ i))) -> length s - length i == 1) tds - then do - symId <- fresh - let argnum = length tds - subjs = map (Subscript . symbolScalarData symId . show) [1 .. argnum] - supjs = map (Superscript . symbolScalarData symId . show) [1 .. argnum] - dot <- evalExpr env (stringToVarExpr ".") - makeITuple (Value (TensorData (Tensor s1 t1 (i1 ++ supjs))):map (Intermediate . ITensor . addscript) (zip subjs $ map valuetoTensor2 tds)) >>= applyFunc env dot - else throwError $ Default "applyfunc" - -applyFunc env (Intermediate (ITensor (Tensor s1 t1 i1))) tds = do - tds <- fromTupleWHNF tds - if length s1 > length i1 && all (\(Intermediate (ITensor (Tensor s _ i))) -> length s - length i == 1) tds - then do - symId <- fresh - let argnum = length tds - subjs = map (Subscript . symbolScalarData symId . show) [1 .. argnum] - supjs = map (Superscript . symbolScalarData symId . show) [1 .. argnum] - dot <- evalExpr env (stringToVarExpr ".") - makeITuple (map Intermediate (ITensor (Tensor s1 t1 (i1 ++ supjs)):map (ITensor . addscript) (zip subjs $ map valuetoTensor2 tds))) >>= applyFunc env dot - else throwError $ Default "applyfunc" - -applyFunc _ (Value (AnonParamFunc env n body)) arg = do - refs <- fromTuple arg - if n == fromIntegral (length refs) - then evalExpr (extendEnv env $ makeBindings (map (\n -> stringToVar $ "::" ++ show n) [1..n]) refs) body - else throwError =<< ArgumentsNumWithNames ["anonymous parameter function"] (fromIntegral n) (length refs) <$> getFuncNameStack -applyFunc _ (Value (Func (Just (Var [funcname] _)) env [name] body)) arg = do - pushFuncName funcname - ref <- newEvaluatedObjectRef arg - result <- evalExpr (extendEnv env $ makeBindings' [name] [ref]) body - popFuncName - return result -applyFunc _ (Value (Func _ env [name] body)) arg = do - ref <- newEvaluatedObjectRef arg - evalExpr (extendEnv env $ makeBindings' [name] [ref]) body -applyFunc _ (Value (Func (Just (Var [funcname] _)) env names body)) arg = do - pushFuncName funcname - refs <- fromTuple arg - result <- if length names == length refs - then evalExpr (extendEnv env $ makeBindings' names refs) body - else throwError =<< ArgumentsNumWithNames names (length names) (length refs) <$> getFuncNameStack - popFuncName - return result -applyFunc _ (Value (Func _ env names body)) arg = do - refs <- fromTuple arg - if length names == length refs - then evalExpr (extendEnv env $ makeBindings' names refs) body - else throwError =<< ArgumentsNumWithNames names (length names) (length refs) <$> getFuncNameStack -applyFunc _ (Value (CFunc _ env name body)) arg = do - refs <- fromTuple arg - seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs) - col <- liftIO . newIORef $ WHNF $ Intermediate $ ICollection seqRef - if not (null refs) - then evalExpr (extendEnv env $ makeBindings' [name] [col]) body - else throwError =<< ArgumentsNumWithNames [name] 1 0 <$> getFuncNameStack -applyFunc _ (Value (PrimitiveFunc _ func)) arg = func arg -applyFunc _ (Value (IOFunc m)) arg = - case arg of - Value World -> m - _ -> throwError =<< TypeMismatch "world" arg <$> getFuncNameStack -applyFunc _ (Value (ScalarData fn@(SingleTerm 1 [(Symbol{}, 1)]))) arg = do - args <- tupleToList arg - mExprs <- mapM (\arg -> case arg of - ScalarData _ -> extractScalar arg - _ -> throwError =<< EgisonBug "to use undefined functions, you have to use ScalarData args" <$> getFuncNameStack) args - return (Value (ScalarData (SingleTerm 1 [(Apply fn mExprs, 1)]))) -applyFunc _ whnf _ = throwError =<< TypeMismatch "function" whnf <$> getFuncNameStack - -refArray :: WHNFData -> [EgisonValue] -> EvalM WHNFData -refArray val [] = return val -refArray (Value (IntHash hash)) (index:indices) = do - key <- fromEgison index - case HL.lookup key hash of - Just val -> refArray (Value val) indices - Nothing -> return $ Value Undefined -refArray (Intermediate (IIntHash hash)) (index:indices) = do - key <- fromEgison index - case HL.lookup key hash of - Just ref -> evalRef ref >>= flip refArray indices - Nothing -> return $ Value Undefined -refArray (Value (CharHash hash)) (index:indices) = do - key <- fromEgison index - case HL.lookup key hash of - Just val -> refArray (Value val) indices - Nothing -> return $ Value Undefined -refArray (Intermediate (ICharHash hash)) (index:indices) = do - key <- fromEgison index - case HL.lookup key hash of - Just ref -> evalRef ref >>= flip refArray indices - Nothing -> return $ Value Undefined -refArray (Value (StrHash hash)) (index:indices) = do - key <- fromEgison index - case HL.lookup key hash of - Just val -> refArray (Value val) indices - Nothing -> return $ Value Undefined -refArray (Intermediate (IStrHash hash)) (index:indices) = do - key <- fromEgison index - case HL.lookup key hash of - Just ref -> evalRef ref >>= flip refArray indices - Nothing -> return $ Value Undefined -refArray val _ = throwError =<< TypeMismatch "array or hash" val <$> getFuncNameStack - -newThunk :: Env -> EgisonExpr -> Object -newThunk env expr = Thunk $ evalExpr env expr - -newObjectRef :: Env -> EgisonExpr -> EvalM ObjectRef -newObjectRef env expr = liftIO $ newIORef $ newThunk env expr - -writeObjectRef :: ObjectRef -> WHNFData -> EvalM () -writeObjectRef ref val = liftIO . writeIORef ref $ WHNF val - -newEvaluatedObjectRef :: WHNFData -> EvalM ObjectRef -newEvaluatedObjectRef = liftIO . newIORef . WHNF - -makeBindings :: [Var] -> [ObjectRef] -> [Binding] -makeBindings = zip - -makeBindings' :: [String] -> [ObjectRef] -> [Binding] -makeBindings' xs = zip (map stringToVar xs) - -recursiveBind :: Env -> [(Var, EgisonExpr)] -> EvalM Env -recursiveBind env bindings = do - let (names, _) = unzip bindings - refs <- replicateM (length bindings) $ newObjectRef nullEnv UndefinedExpr - let env' = extendEnv env $ makeBindings names refs - let Env frame _ = env' - zipWithM_ (\ref (name,expr) -> - case expr of - MemoizedLambdaExpr names body -> do - hashRef <- liftIO $ newIORef HL.empty - liftIO . writeIORef ref . WHNF . Value $ MemoizedFunc (Just name) ref hashRef env' names body - LambdaExpr _ _ -> do - whnf <- evalExpr env' expr - case whnf of - Value (Func _ env args body) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body) - CambdaExpr _ _ -> do - whnf <- evalExpr env' expr - case whnf of - Value (CFunc _ env arg body) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body) - FunctionExpr args -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) $ FunctionExpr args - _ | isVarWithIndices name -> liftIO . writeIORef ref . Thunk $ evalExpr (Env frame (Just $ varToVarWithIndices name)) expr - | otherwise -> liftIO . writeIORef ref . Thunk $ evalExpr env' expr) - refs bindings - return env' - where - isVarWithIndices :: Var -> Bool - isVarWithIndices (Var _ xs) = not $ null xs - -recursiveRebind :: Env -> (Var, EgisonExpr) -> EvalM Env -recursiveRebind env (name, expr) = do - case refVar env name of - Nothing -> throwError =<< UnboundVariable (prettyStr name) <$> getFuncNameStack - Just ref -> case expr of - MemoizedLambdaExpr names body -> do - hashRef <- liftIO $ newIORef HL.empty - liftIO . writeIORef ref . WHNF . Value $ MemoizedFunc (Just name) ref hashRef env names body - LambdaExpr _ _ -> do - whnf <- evalExpr env expr - case whnf of - Value (Func _ env args body) -> liftIO . writeIORef ref . WHNF $ Value (Func (Just name) env args body) - CambdaExpr _ _ -> do - whnf <- evalExpr env expr - case whnf of - Value (CFunc _ env arg body) -> liftIO . writeIORef ref . WHNF $ Value (CFunc (Just name) env arg body) - _ -> liftIO . writeIORef ref . Thunk $ evalExpr env expr - return env - --- --- Pattern Match --- - -patternMatch :: PMMode -> Env -> EgisonPattern -> WHNFData -> Matcher -> EvalM (MList EvalM Match) -patternMatch pmmode env pattern target matcher = - case pmmode of - DFSMode -> processMStatesAllDFS (msingleton initMState) - BFSMode -> processMStatesAll [msingleton initMState] - where - initMState = MState { mStateEnv = env - , loopPatCtx = [] - , seqPatCtx = [] - , mStateBindings = [] - , mTrees = [MAtom pattern target matcher] - } - -processMStatesAllDFS :: MList EvalM MatchingState -> EvalM (MList EvalM Match) -processMStatesAllDFS MNil = return MNil -processMStatesAllDFS (MCons (MState _ _ [] bindings []) ms) = MCons bindings . processMStatesAllDFS <$> ms -processMStatesAllDFS (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS - -processMStatesAllDFSForall :: MList EvalM MatchingState -> EvalM (MList EvalM MatchingState) -processMStatesAllDFSForall MNil = return MNil -processMStatesAllDFSForall (MCons mstate@(MState _ _ (ForallPatContext _ _ : _) _ []) ms) = MCons mstate . processMStatesAllDFSForall <$> ms -processMStatesAllDFSForall (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFSForall - -processMStatesAll :: [MList EvalM MatchingState] -> EvalM (MList EvalM Match) -processMStatesAll [] = return MNil -processMStatesAll streams = do - (matches, streams') <- mapM processMStates streams >>= extractMatches . concat - mappend (fromList matches) $ processMStatesAll streams' - -processMStates :: MList EvalM MatchingState -> EvalM [MList EvalM MatchingState] -processMStates MNil = return [] -processMStates (MCons state stream) = (\x y -> [x, y]) <$> processMState state <*> stream - -extractMatches :: [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState]) -extractMatches = extractMatches' ([], []) - where - extractMatches' :: ([Match], [MList EvalM MatchingState]) -> [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState]) - extractMatches' (xs, ys) [] = return (xs, ys) - extractMatches' (xs, ys) (MCons (gatherBindings -> Just bindings) states : rest) = do - states' <- states - extractMatches' (xs ++ [bindings], ys ++ [states']) rest - extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest - -gatherBindings :: MatchingState -> Maybe [Binding] -gatherBindings mstate@MState{ seqPatCtx = [], mTrees = [] } = return (mStateBindings mstate) -gatherBindings _ = Nothing - -processMState :: MatchingState -> EvalM (MList EvalM MatchingState) -processMState state = - if nullMState state - then processMState' state - else case splitMState state of - (1, state1, state2) -> do - result <- processMStatesAllDFS (msingleton state1) - case result of - MNil -> return $ msingleton state2 - _ -> return MNil - (0, MState e l s b [MAtom (ForallPat p1 p2) m t], MState{ mTrees = trees }) -> do - states <- processMStatesAllDFSForall (msingleton (MState e l (ForallPatContext [] []:s) b [MAtom p1 m t])) - statess' <- mmap (\(MState e' l' (ForallPatContext ms ts:s') b' []) -> do - let mat' = makeTuple ms - tgt' <- makeITuple ts - processMStatesAllDFSForall (msingleton (MState e' l' (ForallPatContext [] []:s') b' [MAtom p2 tgt' mat']))) states - b <- mAny (\s -> case s of - MNil -> return True - _ -> 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' - mconcat nstatess - _ -> processMState' state - where - nullMState :: MatchingState -> Bool - nullMState MState{ mTrees = [] } = True - nullMState MState{ mTrees = MNode _ state : _ } = nullMState state - nullMState _ = False - splitMState :: MatchingState -> (Integer, MatchingState, MatchingState) - splitMState mstate@MState{ mTrees = MAtom (NotPat pattern) target matcher : trees } = - (1, mstate { seqPatCtx = [], mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees }) - splitMState mstate@MState{ mTrees = MAtom pattern target matcher : trees } = - (0, mstate { mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees }) - splitMState mstate@MState{ mTrees = MNode penv state' : trees } = - (f, mstate { mTrees = [MNode penv state1] }, mstate { mTrees = MNode penv state2 : trees }) - 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@MState{ seqPatCtx = [], mTrees = [] } = return . msingleton $ mstate -- for forall pattern used in matchAll (not matchAllDFS) - --- Sequential patterns and forall pattern -processMState' mstate@MState{ seqPatCtx = SeqPatContext stack SeqNilPat [] []:seqs, mTrees = [] } = - return . msingleton $ mstate { seqPatCtx = seqs, mTrees = stack } -processMState' mstate@MState{ seqPatCtx = SeqPatContext stack seqPat mats tgts:seqs, mTrees = [] } = do - let mat' = makeTuple mats - tgt' <- makeITuple tgts - return . msingleton $ mstate { seqPatCtx = seqs, mTrees = MAtom seqPat tgt' mat' : stack } -processMState' mstate@MState{ seqPatCtx = ForallPatContext _ _:_, mTrees = [] } = - return . msingleton $ mstate - --- Matching Nodes ---processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwError =<< EgisonBug "should not reach here (empty matching-node)" <$> getFuncNameStack -processMState' mstate@MState{ mTrees = MNode _ MState{ seqPatCtx = [], mTrees = [] }:trees } = return . msingleton $ mstate { mTrees = trees } - -processMState' ms1@MState{ mTrees = MNode penv ms2@MState{ mTrees = MAtom (VarPat name) target matcher:trees' }:trees } = - case lookup name penv of - Just pattern -> - case trees' of - [] -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:trees } - _ -> return . msingleton $ ms1 { mTrees = MAtom pattern target matcher:MNode penv (ms2 { mTrees = trees' }):trees } - Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack - -processMState' ms1@(MState _ _ _ bindings (MNode penv ms2@(MState env' loops' _ _ (MAtom (IndexedPat (VarPat name) indices) target matcher:trees')):trees)) = - case lookup name penv of - Just pattern -> do - let env'' = extendEnvForNonLinearPatterns env' bindings loops' - indices' <- mapM (evalExpr env'' >=> fmap fromInteger . fromWHNF) indices - let pattern' = IndexedPat pattern $ map IntegerExpr indices' - case trees' of - [] -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:trees } - _ -> return . msingleton $ ms1 { mTrees = MAtom pattern' target matcher:MNode penv (ms2 { mTrees = trees' }):trees } - Nothing -> throwError =<< UnboundVariable name <$> getFuncNameStack - -processMState' mstate@MState{ mTrees = MNode penv state:trees } = - processMState' state >>= mmap (\state' -> case state' of ---egi MState { mTrees = [] } -> return $ mstate { mTrees = trees } - _ -> return $ mstate { mTrees = MNode penv state':trees }) - --- Matching Atoms -processMState' mstate@(MState env loops seqs bindings (MAtom pattern target matcher:trees)) = - let env' = extendEnvForNonLinearPatterns env bindings loops in - case pattern of - InductiveOrPApplyPat name args -> - case refVar env (stringToVar name) of - Nothing -> processMState' (mstate { mTrees = MAtom (InductivePat name args) target matcher:trees }) - Just ref -> do - whnf <- evalRef ref - case whnf of - Value PatternFunc{} -> - processMState' (mstate { mTrees = MAtom (PApplyPat (VarExpr (stringToVar name)) args) target matcher:trees }) - _ -> - processMState' (mstate { mTrees = MAtom (InductivePat name args) target matcher:trees }) - - NotPat _ -> throwError =<< EgisonBug "should not reach here (not-pattern)" <$> getFuncNameStack - VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ prettyStr pattern - - LetPat bindings' pattern' -> do - b <- fmap concat (mapM extractBindings bindings') - return . msingleton $ mstate { mStateBindings = b ++ bindings, mTrees = MAtom pattern' target matcher:trees } - where - extractBindings ([name], expr) = makeBindings [name] . (:[]) <$> newObjectRef env' expr - extractBindings (names, expr) = makeBindings names <$> (evalExpr env' expr >>= fromTuple) - - PredPat predicate -> do - func <- evalExpr env' predicate - let arg = target - result <- applyFunc env func arg >>= fromWHNF - if result then return . msingleton $ mstate { mTrees = trees } - else return MNil - - PApplyPat func args -> do - func' <- evalExpr env' func - case func' of - 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 - - DApplyPat func args -> - return . msingleton $ mstate { mTrees = MAtom (InductivePat "apply" [func, toListPat args]) target matcher:trees } - - LoopPat name (LoopRange start ends endPat) pat pat' -> do - startNum <- evalExpr env' start >>= fromWHNF :: (EvalM Integer) - startNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum - 1) - ends' <- evalExpr env' ends - case ends' of - Value (ScalarData _) -> do -- the case when the end numbers are an integer - endsRef <- newEvaluatedObjectRef ends' - inners <- liftIO . newIORef $ Sq.fromList [IElement endsRef] - endsRef' <- liftIO $ newIORef (WHNF (Intermediate (ICollection inners))) - return . msingleton $ mstate { loopPatCtx = LoopPatContext (name, startNumRef) endsRef' endPat pat pat':loops - , mTrees = MAtom ContPat target matcher:trees } - _ -> do -- the case when the end numbers are a collection - endsRef <- newEvaluatedObjectRef ends' - return . msingleton $ mstate { loopPatCtx = LoopPatContext (name, startNumRef) endsRef endPat pat pat':loops - , mTrees = MAtom ContPat target matcher:trees } - ContPat -> - case loops of - [] -> throwError $ Default "cannot use cont pattern except in loop pattern" - LoopPatContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do - startNumWhnf <- evalRef startNumRef - startNum <- fromWHNF startNumWhnf :: (EvalM Integer) - nextNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum + 1) - ends <- evalRef endsRef - b <- isEmptyCollection ends - if b - then return MNil - else do - (carEndsRef, cdrEndsRef) <- fromJust <$> runMaybeT (unconsCollection ends) - b2 <- evalRef cdrEndsRef >>= isEmptyCollection - carEndsNum <- evalRef carEndsRef >>= fromWHNF - return $ if - | startNum > carEndsNum -> MNil - | startNum == carEndsNum && b2 -> - fromList [mstate { loopPatCtx = loops', mTrees = MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees }] - | startNum == carEndsNum -> - fromList [mstate { loopPatCtx = loops', mTrees = MAtom endPat startNumWhnf Something:MAtom pat' target matcher:trees }, - mstate { loopPatCtx = LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }] - | otherwise -> - fromList [mstate { loopPatCtx = LoopPatContext (name, nextNumRef) endsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }] - SeqNilPat -> throwError =<< EgisonBug "should not reach here (seq nil pattern)" <$> getFuncNameStack - SeqConsPat pattern pattern' -> return . msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher] - LaterPatVar -> - case seqs of - [] -> throwError $ Default "cannot use # out of seq patterns" - (SeqPatContext stack pat mats tgts:seqs) -> return . msingleton $ MState env loops (SeqPatContext stack pat (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees - (ForallPatContext mats tgts:seqs) -> return . msingleton $ MState env loops (ForallPatContext (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees - AndPat patterns -> - let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees - in return . msingleton $ mstate { mTrees = trees' } - OrPat patterns -> - return $ fromList $ flip map patterns $ \pat -> - mstate { mTrees = MAtom pat target matcher : trees } - - _ -> - case matcher of - UserMatcher{} -> do - (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher - case length patterns of - 1 -> - mfor targetss $ \ref -> do - targets <- evalRef ref >>= (\x -> return [x]) - let trees' = zipWith3 MAtom patterns targets matchers ++ trees - return $ mstate { mTrees = trees' } - _ -> - mfor targetss $ \ref -> do - targets <- evalRef ref >>= fromTupleWHNF - let trees' = zipWith3 MAtom patterns targets matchers ++ trees - return $ mstate { mTrees = trees' } - - Tuple matchers -> - case pattern of - ValuePat _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees } - WildCard -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees } - PatVar _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees } - IndexedPat _ _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees } - TuplePat patterns -> do - targets <- fromTupleWHNF target - when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack - when (length patterns /= length matchers) $ throwError =<< TupleLength (length patterns) (length matchers) <$> getFuncNameStack - let trees' = zipWith3 MAtom patterns targets matchers ++ trees - return . msingleton $ mstate { mTrees = trees' } - _ -> throwError $ Default $ "should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern - - Something -> - case pattern of - ValuePat valExpr -> do - val <- evalExprDeep env' valExpr - tgtVal <- evalWHNF target - if val == tgtVal - then return . msingleton $ mstate { mTrees = trees } - else return MNil - WildCard -> return . msingleton $ mstate { mTrees = trees } - PatVar name -> do - targetRef <- newEvaluatedObjectRef target - return . msingleton $ mstate { mStateBindings = (name, targetRef):bindings, mTrees = trees } - IndexedPat (PatVar name) indices -> do - indices <- mapM (evalExpr env' >=> fmap fromInteger . fromWHNF) indices - case lookup name bindings of - Just ref -> do - obj <- evalRef ref >>= updateHash indices >>= newEvaluatedObjectRef - return . msingleton $ mstate { mStateBindings = subst name obj bindings, mTrees = trees } - Nothing -> do - obj <- updateHash indices (Intermediate . IIntHash $ HL.empty) >>= newEvaluatedObjectRef - return . msingleton $ mstate { mStateBindings = (name,obj):bindings, mTrees = trees } - where - updateHash :: [Integer] -> WHNFData -> EvalM WHNFData - updateHash [index] (Intermediate (IIntHash hash)) = do - targetRef <- newEvaluatedObjectRef target - return . Intermediate . IIntHash $ HL.insert index targetRef hash - updateHash (index:indices) (Intermediate (IIntHash hash)) = do - val <- maybe (return $ Intermediate $ IIntHash HL.empty) evalRef $ HL.lookup index hash - ref <- updateHash indices val >>= newEvaluatedObjectRef - return . Intermediate . IIntHash $ HL.insert index ref hash - updateHash indices (Value (IntHash hash)) = do - let keys = HL.keys hash - vals <- mapM (newEvaluatedObjectRef . Value) $ HL.elems hash - updateHash indices (Intermediate $ 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 - subst _ _ [] = [] - IndexedPat pattern _ -> throwError $ Default ("invalid indexed-pattern: " ++ prettyStr pattern) - TuplePat patterns -> do - targets <- fromTupleWHNF target - when (length patterns /= length targets) $ throwError =<< TupleLength (length patterns) (length targets) <$> getFuncNameStack - let trees' = zipWith3 MAtom patterns targets (replicate (length patterns) Something) ++ trees - return . msingleton $ mstate { mTrees = trees' } - _ -> throwError $ Default $ "something can only match with a pattern variable. not: " ++ prettyStr pattern - _ -> throwError =<< EgisonBug ("should not reach here. matcher: " ++ show matcher ++ ", pattern: " ++ show pattern) <$> getFuncNameStack - -inductiveMatch :: Env -> EgisonPattern -> WHNFData -> Matcher -> - EvalM ([EgisonPattern], MList EvalM ObjectRef, [Matcher]) -inductiveMatch env pattern target (UserMatcher matcherEnv clauses) = - foldr tryPPMatchClause failPPPatternMatch clauses - where - tryPPMatchClause (pat, matchers, clauses) cont = do - result <- runMaybeT $ primitivePatPatternMatch env pat pattern - case result of - Just ([pattern], bindings) -> do - targetss <- foldr (tryPDMatchClause bindings) failPDPatternMatch clauses - matcher <- evalExpr matcherEnv matchers >>= evalMatcherWHNF - return ([pattern], targetss, [matcher]) - Just (patterns, bindings) -> do - targetss <- foldr (tryPDMatchClause bindings) failPDPatternMatch clauses - matchers <- fromTupleValue <$> (evalExpr matcherEnv matchers >>= evalMatcherWHNF) - return (patterns, targetss, matchers) - _ -> cont - tryPDMatchClause bindings (pat, expr) cont = do - result <- runMaybeT $ primitiveDataPatternMatch pat target - case result of - Just bindings' -> do - let env = extendEnv matcherEnv $ bindings ++ bindings' - evalExpr env expr >>= fromCollection - _ -> cont - failPPPatternMatch = throwError $ Default "failed primitive pattern pattern match" - failPDPatternMatch = throwError $ Default "failed primitive data pattern match" - -primitivePatPatternMatch :: Env -> PrimitivePatPattern -> EgisonPattern -> - MatchM ([EgisonPattern], [Binding]) -primitivePatPatternMatch _ PPWildCard WildCard = return ([], []) -primitivePatPatternMatch _ PPPatVar pattern = return ([pattern], []) -primitivePatPatternMatch env (PPValuePat name) (ValuePat expr) = do - ref <- lift $ newObjectRef env expr - return ([], [(stringToVar name, ref)]) -primitivePatPatternMatch env (PPInductivePat name patterns) (InductivePat name' exprs) - | name == name' && length patterns == length exprs = - (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs - | otherwise = matchFail -primitivePatPatternMatch env (PPTuplePat patterns) (TuplePat exprs) - | length patterns == length exprs = - (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs - | otherwise = matchFail -primitivePatPatternMatch _ _ _ = matchFail - -primitiveDataPatternMatch :: PrimitiveDataPattern -> WHNFData -> MatchM [Binding] -primitiveDataPatternMatch PDWildCard _ = return [] -primitiveDataPatternMatch (PDPatVar name) whnf = do - ref <- lift $ newEvaluatedObjectRef whnf - return [(stringToVar name, ref)] -primitiveDataPatternMatch (PDInductivePat name patterns) whnf = - case whnf of - Intermediate (IInductiveData name' refs) | name == name' -> do - whnfs <- lift $ mapM evalRef refs - concat <$> zipWithM primitiveDataPatternMatch patterns whnfs - Value (InductiveData name' vals) | name == name' -> do - let whnfs = map Value vals - concat <$> zipWithM primitiveDataPatternMatch patterns whnfs - _ -> matchFail -primitiveDataPatternMatch (PDTuplePat patterns) whnf = - case whnf of - Intermediate (ITuple refs) -> do - whnfs <- lift $ mapM evalRef refs - concat <$> zipWithM primitiveDataPatternMatch patterns whnfs - Value (Tuple vals) -> do - let whnfs = map Value vals - concat <$> zipWithM primitiveDataPatternMatch patterns whnfs - _ -> matchFail -primitiveDataPatternMatch PDEmptyPat whnf = do - isEmpty <- lift $ isEmptyCollection whnf - if isEmpty then return [] else matchFail -primitiveDataPatternMatch (PDConsPat pattern pattern') whnf = do - (head, tail) <- unconsCollection whnf - head' <- lift $ evalRef head - tail' <- lift $ evalRef tail - (++) <$> primitiveDataPatternMatch pattern head' - <*> primitiveDataPatternMatch pattern' tail' -primitiveDataPatternMatch (PDSnocPat pattern pattern') whnf = do - (init, last) <- unsnocCollection whnf - init' <- lift $ evalRef init - last' <- lift $ evalRef last - (++) <$> primitiveDataPatternMatch pattern init' - <*> primitiveDataPatternMatch pattern' last' -primitiveDataPatternMatch (PDConstantPat expr) whnf = do - target <- either (const matchFail) return $ extractPrimitiveValue whnf - isEqual <- lift $ (==) <$> evalExprDeep nullEnv expr <*> pure target - if isEqual then return [] else matchFail - where - extractPrimitiveValue :: WHNFData -> Either ([String] -> EgisonError) EgisonValue - extractPrimitiveValue (Value val@(Char _)) = return val - extractPrimitiveValue (Value val@(Bool _)) = return val - extractPrimitiveValue (Value val@(ScalarData _)) = return val - extractPrimitiveValue (Value val@(Float _)) = return val - extractPrimitiveValue whnf = - -- we don't need to extract call stack since detailed error information is not used - throwError $ TypeMismatch "primitive value" whnf - -expandCollection :: WHNFData -> EvalM (Seq Inner) -expandCollection (Value (Collection vals)) = - mapM (fmap IElement . newEvaluatedObjectRef . Value) vals -expandCollection (Intermediate (ICollection innersRef)) = liftIO $ readIORef innersRef -expandCollection val = throwError =<< TypeMismatch "collection" val <$> getFuncNameStack - -isEmptyCollection :: WHNFData -> EvalM Bool -isEmptyCollection (Value (Collection col)) = return $ Sq.null col -isEmptyCollection coll@(Intermediate (ICollection innersRef)) = do - inners <- liftIO $ readIORef innersRef - case Sq.viewl inners of - EmptyL -> return True - ISubCollection ref' :< tInners -> do - hInners <- evalRef ref' >>= expandCollection - liftIO $ writeIORef innersRef (hInners >< tInners) - isEmptyCollection coll - _ -> return False -isEmptyCollection _ = return False - -unconsCollection :: WHNFData -> MatchM (ObjectRef, ObjectRef) -unconsCollection (Value (Collection col)) = - case Sq.viewl col of - EmptyL -> matchFail - val :< vals -> - lift $ (,) <$> newEvaluatedObjectRef (Value val) - <*> newEvaluatedObjectRef (Value $ Collection vals) -unconsCollection coll@(Intermediate (ICollection innersRef)) = do - inners <- liftIO $ readIORef innersRef - case Sq.viewl inners of - EmptyL -> matchFail - IElement ref' :< tInners -> do - tInnersRef <- liftIO $ newIORef tInners - lift $ (ref', ) <$> newEvaluatedObjectRef (Intermediate $ ICollection tInnersRef) - ISubCollection ref' :< tInners -> do - hInners <- lift $ evalRef ref' >>= expandCollection - liftIO $ writeIORef innersRef (hInners >< tInners) - unconsCollection coll -unconsCollection _ = matchFail - -unsnocCollection :: WHNFData -> MatchM (ObjectRef, ObjectRef) -unsnocCollection (Value (Collection col)) = - case Sq.viewr col of - EmptyR -> matchFail - vals :> val -> - lift $ (,) <$> newEvaluatedObjectRef (Value $ Collection vals) - <*> newEvaluatedObjectRef (Value val) -unsnocCollection coll@(Intermediate (ICollection innersRef)) = do - inners <- liftIO $ readIORef innersRef - case Sq.viewr inners of - EmptyR -> matchFail - hInners :> IElement ref' -> do - hInnersRef <- liftIO $ newIORef hInners - lift $ (, ref') <$> newEvaluatedObjectRef (Intermediate $ ICollection hInnersRef) - hInners :> ISubCollection ref' -> do - tInners <- lift $ evalRef ref' >>= expandCollection - liftIO $ writeIORef innersRef (hInners >< tInners) - unsnocCollection coll -unsnocCollection _ = matchFail - -extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopPatContext] -> Env -extendEnvForNonLinearPatterns env bindings loops = extendEnv env $ bindings ++ map (\(LoopPatContext binding _ _ _ _) -> binding) loops - -evalMatcherWHNF :: WHNFData -> EvalM Matcher -evalMatcherWHNF (Value matcher@Something) = return matcher -evalMatcherWHNF (Value matcher@UserMatcher{}) = return matcher -evalMatcherWHNF (Value (Tuple ms)) = Tuple <$> mapM (evalMatcherWHNF . Value) ms -evalMatcherWHNF (Intermediate (ITuple refs)) = do - whnfs <- mapM evalRef refs - ms <- mapM evalMatcherWHNF whnfs - return $ Tuple ms -evalMatcherWHNF whnf = throwError =<< TypeMismatch "matcher" whnf <$> getFuncNameStack - --- --- Util --- -toListPat :: [EgisonPattern] -> EgisonPattern -toListPat [] = InductivePat "nil" [] -toListPat (pat:pats) = InductivePat "cons" [pat, toListPat pats] - -fromTuple :: WHNFData -> EvalM [ObjectRef] -fromTuple (Intermediate (ITuple refs)) = return refs -fromTuple (Value (Tuple vals)) = mapM (newEvaluatedObjectRef . Value) vals -fromTuple whnf = return <$> newEvaluatedObjectRef whnf - -fromTupleWHNF :: WHNFData -> EvalM [WHNFData] -fromTupleWHNF (Intermediate (ITuple refs)) = mapM evalRef refs -fromTupleWHNF (Value (Tuple vals)) = return $ map Value vals -fromTupleWHNF whnf = return [whnf] - -fromTupleValue :: EgisonValue -> [EgisonValue] -fromTupleValue (Tuple vals) = vals -fromTupleValue val = [val] - -fromCollection :: WHNFData -> EvalM (MList EvalM ObjectRef) -fromCollection (Value (Collection vals)) = - if Sq.null vals then return MNil - else fromSeq <$> mapM (newEvaluatedObjectRef . Value) vals -fromCollection whnf@(Intermediate (ICollection _)) = do - isEmpty <- isEmptyCollection whnf - if isEmpty - then return MNil - else do - (head, tail) <- fromJust <$> runMaybeT (unconsCollection whnf) - tail' <- evalRef tail - return $ MCons head (fromCollection tail') -fromCollection whnf = throwError =<< TypeMismatch "collection" whnf <$> getFuncNameStack - -tupleToList :: WHNFData -> EvalM [EgisonValue] -tupleToList whnf = do - val <- evalWHNF whnf - return $ tupleToList' val - where - tupleToList' (Tuple vals) = vals - tupleToList' val = [val] - -collectionToList :: WHNFData -> EvalM [EgisonValue] -collectionToList whnf = do - val <- evalWHNF whnf - collectionToList' val - where - collectionToList' :: EgisonValue -> EvalM [EgisonValue] - collectionToList' (Collection sq) = return $ toList sq - collectionToList' val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack - -makeTuple :: [EgisonValue] -> EgisonValue -makeTuple [] = Tuple [] -makeTuple [x] = x -makeTuple xs = Tuple xs - -makeITuple :: [WHNFData] -> EvalM WHNFData -makeITuple [] = return $ Intermediate (ITuple []) -makeITuple [x] = return x -makeITuple xs = Intermediate . ITuple <$> mapM newEvaluatedObjectRef xs - -makeICollection :: [WHNFData] -> EvalM WHNFData -makeICollection xs = do - is <- mapM (\x -> IElement <$> newEvaluatedObjectRef x) xs - v <- liftIO $ newIORef $ Sq.fromList is - return $ Intermediate $ ICollection v - --- Refer the specified tensor index with potential overriding of the index. -refTensorWithOverride :: HasTensor a => Bool -> [Index EgisonValue] -> Tensor a -> EvalM a -refTensorWithOverride override js (Tensor ns xs is) = - tref js' (Tensor ns xs js') >>= toTensor >>= tContract' >>= fromTensor + -- * Egison code evaluation + ( evalExprShallow + , evalExprDeep + , evalWHNF + -- * Environment + , recursiveBind + -- * Pattern matching + , patternMatch + ) where + +import Prelude hiding (mapM, mappend, mconcat) + +import Control.Arrow +import Control.Monad.Except (throwError) +import Control.Monad.State hiding (mapM, join) +import Control.Monad.Trans.Maybe + +import Data.Char (isUpper) +import Data.Foldable (toList) +import Data.IORef +import Data.List (partition) +import Data.Maybe +import qualified Data.Sequence as Sq +import Data.Traversable (mapM) + +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.IExpr +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 +evalConstant (BoolExpr b) = Bool b +evalConstant (IntegerExpr x) = toEgison x +evalConstant (FloatExpr x) = Float x +evalConstant SomethingExpr = Something +evalConstant UndefinedExpr = Undefined + +evalExprShallow :: Env -> IExpr -> EvalM WHNFData +evalExprShallow _ (IConstantExpr c) = return $ Value (evalConstant c) + +evalExprShallow env (IQuoteExpr expr) = do + 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 + +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 + +evalExprShallow env (IVarExpr name) = + case refVar env (Var name []) of + Nothing | isUpper (head name) -> + return $ Value (InductiveData name []) + Nothing -> return $ Value (symbolScalarData "" name) + Just ref -> evalRef ref + +evalExprShallow _ (ITupleExpr []) = return . Value $ Tuple [] +evalExprShallow env (ITupleExpr [expr]) = evalExprShallow env expr +evalExprShallow env (ITupleExpr exprs) = ITuple <$> mapM (newThunkRef env) exprs + +evalExprShallow _ (ICollectionExpr []) = return . Value $ Collection Sq.empty + +evalExprShallow env (ICollectionExpr inners) = do + inners' <- mapM ((IElement <$>) . newThunkRef env) inners + innersSeq <- liftIO $ newIORef $ Sq.fromList inners' + return $ ICollection innersSeq + +evalExprShallow env (IConsExpr x xs) = do + x' <- newThunkRef env x + xs' <- newThunkRef env xs + innersSeq <- liftIO $ newIORef $ Sq.fromList [IElement x', ISubCollection xs'] + return $ ICollection innersSeq + +evalExprShallow env (IJoinExpr xs ys) = do + xs' <- newThunkRef env xs + ys' <- newThunkRef env ys + innersSeq <- liftIO $ newIORef $ Sq.fromList [ISubCollection xs', ISubCollection ys'] + return $ ICollection innersSeq + +evalExprShallow env@(Env frame maybe_vwi) (IVectorExpr exprs) = do + let n = toInteger (length exprs) + whnfs <- zipWithM evalWithIndex exprs [1..] + case whnfs of + ITensor Tensor{}:_ -> + zipWithM f whnfs [1..] >>= 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 + +evalExprShallow env (ITensorExpr nsExpr xsExpr) = do + nsWhnf <- evalExprShallow env nsExpr + ns <- (collectionToRefs nsWhnf >>= fromMList >>= mapM evalRefDeep >>= mapM fromEgison) :: EvalM [Integer] + xsWhnf <- evalExprShallow env xsExpr + xs <- collectionToRefs xsWhnf >>= fromMList >>= mapM evalRef + if product ns == toInteger (length xs) + then makeITensorFromWHNF ns xs + else throwError =<< InconsistentTensorShape <$> getFuncNameStack + +evalExprShallow env (IHashExpr assocs) = do + let (keyExprs, exprs) = unzip assocs + keyWhnfs <- mapM (evalExprShallow env) keyExprs + keys <- mapM makeHashKey keyWhnfs + refs <- mapM (newThunkRef env) exprs + case keys of + CharKey _ : _ -> do + let keys' = map (\case CharKey c -> c) keys + return . ICharHash $ HL.fromList $ zip keys' refs + StrKey _ : _ -> do + let keys' = map (\case StrKey s -> s) keys + return . IStrHash $ HL.fromList $ zip keys' refs + _ -> do + let keys' = map (\case IntKey i -> i) keys + return . IIntHash $ HL.fromList $ zip keys' refs + where + makeHashKey :: WHNFData -> EvalM EgisonHashKey + makeHashKey (Value val) = + case val of + 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 + +evalExprShallow env (IIndexedExpr override expr indices) = do + -- Tensor or hash + tensor <- case expr of + IVarExpr xs -> do + let mObjRef = refVar env (Var xs (map (const () <$>) indices)) + case mObjRef of + Just objRef -> evalRef objRef + Nothing -> evalExprShallow env expr + _ -> evalExprShallow env expr + case tensor 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 (TensorData t@Tensor{}) -> do + js <- mapM evalIndex indices + Value <$> refTensorWithOverride override js t + ITensor t@Tensor{} -> do + js <- mapM evalIndex indices + refTensorWithOverride override js t + _ -> do + js <- mapM evalIndex indices + refHash tensor (map extractIndex js) + where + evalIndex :: Index IExpr -> EvalM (Index EgisonValue) + evalIndex index = traverse (evalExprDeep env) index + + evalIndexToScalar :: Index IExpr -> EvalM (Index ScalarData) + evalIndexToScalar index = traverse ((extractScalar =<<) . evalExprDeep env) index + +evalExprShallow env (ISubrefsExpr override expr jsExpr) = do + js <- map Sub <$> (evalExprDeep env jsExpr >>= collectionToList) + tensor <- case expr of + IVarExpr xs -> do + let mObjRef = refVar env (Var xs (map (\_ -> Sub ()) js)) + case mObjRef of + Just objRef -> evalRef objRef + Nothing -> evalExprShallow env expr + _ -> evalExprShallow env expr + case tensor of + Value (ScalarData _) -> return tensor + Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t + ITensor t@Tensor{} -> refTensorWithOverride override js t + _ -> throwError =<< NotImplemented "subrefs" <$> getFuncNameStack + +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)) + case mObjRef of + Just objRef -> evalRef objRef + Nothing -> evalExprShallow env expr + _ -> evalExprShallow env expr + case tensor of + Value (ScalarData _) -> return tensor + Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t + ITensor t@Tensor{} -> refTensorWithOverride override js t + _ -> throwError =<< NotImplemented "suprefs" <$> getFuncNameStack + +evalExprShallow env (IUserrefsExpr _ expr jsExpr) = do + val <- evalExprDeep env expr + js <- map User <$> (evalExprDeep env jsExpr >>= collectionToList >>= mapM extractScalar) + 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 + +evalExprShallow env (ILambdaExpr fnname names expr) = do + return . Value $ Func fnname env names expr + +evalExprShallow env (IMemoizedLambdaExpr names body) = do + hashRef <- liftIO $ newIORef HL.empty + return . Value $ MemoizedFunc hashRef env names body + +evalExprShallow env (ICambdaExpr name expr) = return . Value $ CFunc env name expr + +evalExprShallow env (IPatternFunctionExpr names pattern) = return . Value $ PatternFunc env names pattern + +evalExprShallow (Env _ Nothing) (IFunctionExpr _) = throwError $ Default "function symbol is not bound to a variable" + +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)]) + +evalExprShallow env (IIfExpr test expr expr') = do + test <- evalExprDeep env test >>= fromEgison + evalExprShallow env $ if test then expr else expr' + +evalExprShallow env (ILetExpr bindings expr) = do + binding <- concat <$> mapM extractBindings bindings + evalExprShallow (extendEnv env binding) expr + where + extractBindings :: IBindingExpr -> EvalM [Binding] + extractBindings (PDPatVar var, expr) = + makeBindings [var] . (:[]) <$> newThunkRef (memorizeVarInEnv env var) expr + extractBindings (pdp, expr) = do + thunk <- newThunkRef env expr + bindPrimitiveDataPattern pdp thunk + +evalExprShallow env (ILetRecExpr bindings expr) = do + env' <- recursiveMatchBind env bindings + evalExprShallow env' expr + +evalExprShallow env (ITransposeExpr vars expr) = do + syms <- evalExprDeep env vars >>= collectionToList + whnf <- evalExprShallow env expr + case whnf of + ITensor t -> ITensor <$> tTranspose' syms t + Value (TensorData t) -> Value . TensorData <$> tTranspose' syms t + _ -> return whnf + +evalExprShallow env (IFlipIndicesExpr expr) = do + whnf <- evalExprShallow env expr + case whnf of + ITensor t -> ITensor <$> tFlipIndices t + Value (TensorData t) -> Value . TensorData <$> tFlipIndices t + _ -> return whnf + +evalExprShallow env (IWithSymbolsExpr vars expr) = do + symId <- fresh + syms <- mapM (newEvaluatedObjectRef . Value . symbolScalarData symId) vars + whnf <- evalExprShallow (extendEnv env (makeBindings' vars syms)) expr + case whnf of + Value (TensorData t@Tensor{}) -> + Value . TensorData <$> removeTmpScripts symId t + ITensor t@Tensor{} -> + ITensor <$> removeTmpScripts symId t + _ -> return whnf + where + isTmpSymbol :: String -> Index EgisonValue -> Bool + isTmpSymbol symId index = symId == getSymId (extractIndex index) + + removeTmpScripts :: String -> Tensor a -> EvalM (Tensor a) + removeTmpScripts symId (Tensor s xs is) = do + let (ds, js) = partition (isTmpSymbol symId) is + Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is) + return (Tensor s ys js) + + +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)] + where + genLet (names, expr) expr' = + ILetExpr [(PDTuplePat (map PDPatVar [stringToVar "#1", stringToVar "#2"]), IApplyExpr expr [IVarExpr "#1"])] $ + ILetExpr [(names, IVarExpr "#2")] expr' + +evalExprShallow env (IMatchAllExpr pmmode target matcher clauses) = do + target <- evalExprShallow env target + matcher <- evalExprShallow env matcher >>= evalMatcherWHNF + f matcher target >>= fromMList + where + fromMList :: MList EvalM WHNFData -> EvalM WHNFData + fromMList MNil = return . Value $ Collection Sq.empty + fromMList (MCons val m) = do + head <- IElement <$> newEvaluatedObjectRef val + tail <- ISubCollection <$> (liftIO . newIORef . Thunk $ m >>= fromMList) + seqRef <- liftIO . newIORef $ Sq.fromList [head, tail] + return $ ICollection seqRef + f matcher target = do + let tryMatchClause (pattern, expr) results = do + result <- patternMatch pmmode env pattern target matcher + mmap (flip evalExprShallow expr . extendEnv env) result >>= (`mappend` results) + mfoldr tryMatchClause (return MNil) (fromList clauses) + +evalExprShallow env (IMatchExpr pmmode target matcher clauses) = do + target <- evalExprShallow env target + matcher <- evalExprShallow env matcher >>= evalMatcherWHNF + f matcher target + where + f matcher target = do + let tryMatchClause (pattern, expr) cont = do + result <- patternMatch pmmode env pattern target matcher + case result of + MCons bindings _ -> evalExprShallow (extendEnv env bindings) expr + MNil -> cont + callstack <- getFuncNameStack + foldr tryMatchClause (throwError $ MatchFailure callstack) clauses + +evalExprShallow env (ISeqExpr expr1 expr2) = do + _ <- evalExprDeep env expr1 + evalExprShallow env expr2 + +evalExprShallow env (ICApplyExpr func arg) = do + func <- evalExprShallow env func + args <- evalExprDeep env arg >>= collectionToList + case func of + Value (MemoizedFunc hashRef env names body) -> + evalMemoizedFunc hashRef env names body args + _ -> applyObj env func (map (WHNF . Value) args) + +evalExprShallow env (IApplyExpr func args) = do + func <- appendDF 0 <$> evalExprShallow env func + case func of + Value (InductiveData name []) -> + IInductiveData name <$> mapM (newThunkRef env) args + Value (TensorData t@Tensor{}) -> do + let args' = map (newThunk env) args + tMap (\f -> newApplyObjThunkRef env (Value f) args') t >>= fromTensor >>= removeDF + ITensor t@Tensor{} -> do + let args' = map (newThunk env) args + tMap (\f -> do + f <- evalRef f + newApplyObjThunkRef env f args') t >>= fromTensor >>= removeDF + Value (MemoizedFunc hashRef env' names body) -> do + args <- mapM (evalExprDeep env) args + evalMemoizedFunc hashRef env' names body args + _ -> do + let args' = map (newThunk env) args + applyObj env func args' >>= removeDF + +evalExprShallow env (IWedgeApplyExpr func args) = do + func <- appendDF 0 <$> evalExprShallow env func + args <- mapM (evalExprShallow env) args + let args' = map WHNF (zipWith appendDF [1..] args) + case func of + Value (TensorData t@Tensor{}) -> + tMap (\f -> newApplyObjThunkRef env (Value f) args') t >>= fromTensor + ITensor t@Tensor{} -> + tMap (\f -> do + f <- evalRef f + newApplyObjThunkRef env f args') t >>= fromTensor + Value (MemoizedFunc hashRef env names body) -> do + args <- mapM evalWHNF args + evalMemoizedFunc hashRef env names body args + _ -> applyObj env func args' >>= removeDF + +evalExprShallow env (IMatcherExpr info) = return $ Value $ UserMatcher env info + +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) + return $ newITensor ns xs + where + indexToWHNF :: Env -> [EgisonValue] {- index -} -> EvalM ObjectRef + indexToWHNF (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) + +evalExprShallow env (ITensorContractExpr tExpr) = do + whnf <- evalExprShallow env tExpr + case whnf of + ITensor t@Tensor{} -> do + ts <- tContract t >>= mapM fromTensor + makeICollection ts + Value (TensorData t@Tensor{}) -> do + ts <- tContract t >>= mapM fromTensor + return $ Value $ Collection $ Sq.fromList ts + _ -> makeICollection [whnf] + +evalExprShallow env (ITensorMapExpr fnExpr tExpr) = do + fn <- evalExprShallow env fnExpr + whnf <- evalExprShallow env tExpr + case whnf of + ITensor t -> + tMap (\x -> newApplyThunkRef env fn [x]) t >>= fromTensor + Value (TensorData t) -> + tMap (\x -> newApplyObjThunkRef env fn [WHNF (Value x)]) t >>= fromTensor + _ -> applyObj env fn [WHNF whnf] + +evalExprShallow env (ITensorMap2Expr fnExpr t1Expr t2Expr) = do + fn <- evalExprShallow env fnExpr + whnf1 <- evalExprShallow env t1Expr + whnf2 <- evalExprShallow env t2Expr + case (whnf1, whnf2) of + -- both of arguments are tensors + (ITensor t1, ITensor t2) -> + tMap2 (\x y -> newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor + (ITensor t1, Value (TensorData t2)) -> do + tMap2 (\x y -> do + y <- newEvaluatedObjectRef (Value y) + newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor + (Value (TensorData t1), ITensor t2) -> do + tMap2 (\x y -> do + x <- newEvaluatedObjectRef (Value x) + newApplyThunkRef env fn [x, y]) t1 t2 >>= fromTensor + (Value (TensorData t1), Value (TensorData t2)) -> + tMap2 (\x y -> newApplyObjThunkRef env fn [WHNF (Value x), WHNF (Value y)]) t1 t2 >>= fromTensor + -- an argument is scalar + (ITensor t1, _) -> do + y <- newEvaluatedObjectRef whnf2 + tMap (\x -> newApplyThunkRef env fn [x, y]) t1 >>= fromTensor + (_, ITensor t2) -> do + x <- newEvaluatedObjectRef whnf1 + tMap (\y -> newApplyThunkRef env fn [x, y]) t2 >>= fromTensor + (Value (TensorData t1), _) -> do + y <- newEvaluatedObjectRef whnf2 + tMap (\x -> do + x <- newEvaluatedObjectRef (Value x) + newApplyThunkRef env fn [x, y]) t1 >>= fromTensor + (_, Value (TensorData t2)) -> do + x <- newEvaluatedObjectRef whnf1 + tMap (\y -> do + y <- newEvaluatedObjectRef (Value y) + newApplyThunkRef env fn [x, y]) t2 >>= fromTensor + _ -> applyObj env fn [WHNF whnf1, WHNF whnf2] + +evalExprShallow _ expr = throwError =<< NotImplemented ("evalExprShallow for " ++ show expr) <$> getFuncNameStack + +evalExprDeep :: Env -> IExpr -> EvalM EgisonValue +evalExprDeep env expr = evalExprShallow env expr >>= evalWHNF + +evalRefDeep :: ObjectRef -> EvalM EgisonValue +evalRefDeep ref = do + obj <- liftIO $ readIORef ref + case obj of + WHNF (Value val) -> return val + WHNF val -> do + val <- evalWHNF val + writeObjectRef ref $ Value val + return val + Thunk thunk -> do + val <- thunk >>= evalWHNF + writeObjectRef ref $ Value val + return val + +evalMemoizedFunc + :: (IORef (HL.HashMap [Integer] WHNFData)) -> Env -> [String] -> IExpr + -> [EgisonValue] -> EvalM WHNFData +evalMemoizedFunc hashRef env names body args = do + indices <- mapM fromEgison args + hash <- liftIO $ readIORef hashRef + 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) + liftIO $ modifyIORef hashRef (HL.insert indices whnf) + return whnf + +evalWHNF :: WHNFData -> EvalM EgisonValue +evalWHNF (Value val) = return val +evalWHNF (IInductiveData name refs) = + InductiveData name <$> mapM evalRefDeep refs +evalWHNF (IIntHash refs) = IntHash <$> mapM evalRefDeep refs +evalWHNF (ICharHash refs) = CharHash <$> mapM evalRefDeep refs +evalWHNF (IStrHash refs) = StrHash <$> mapM evalRefDeep refs +evalWHNF (ITuple [ref]) = evalRefDeep ref +evalWHNF (ITuple refs) = Tuple <$> mapM evalRefDeep refs +evalWHNF (ITensor (Tensor ns whnfs js)) = do + vals <- V.mapM evalRefDeep whnfs + return $ TensorData $ Tensor ns vals js +evalWHNF coll = Collection <$> (collectionToRefs coll >>= fromMList >>= mapM evalRefDeep . Sq.fromList) + +addscript :: (Index EgisonValue, Tensor a) -> Tensor a +addscript (subj, Tensor s t i) = Tensor s t (i ++ [subj]) + +newApplyThunk :: Env -> WHNFData -> [ObjectRef] -> Object +newApplyThunk env fn refs = Thunk $ applyRef env fn refs + +newApplyThunkRef :: Env -> WHNFData -> [ObjectRef] -> EvalM ObjectRef +newApplyThunkRef env fn refs = liftIO . newIORef $ newApplyThunk env fn refs + +newApplyObjThunk :: Env -> WHNFData -> [Object] -> Object +newApplyObjThunk env fn objs = Thunk $ applyObj env fn objs + +newApplyObjThunkRef :: Env -> WHNFData -> [Object] -> EvalM ObjectRef +newApplyObjThunkRef env fn objs = liftIO . newIORef $ newApplyObjThunk env fn objs + +applyRef :: Env -> WHNFData -> [ObjectRef] -> EvalM WHNFData +applyRef env (Value (TensorData (Tensor s1 t1 i1))) refs = do + tds <- mapM evalRef refs + if length s1 > length i1 && all (\(ITensor (Tensor s _ i)) -> length s - length i == 1) tds + then do + symId <- fresh + let argnum = length tds + subjs = map (Sub . symbolScalarData symId . show) [1 .. argnum] + supjs = map (Sup . symbolScalarData symId . show) [1 .. argnum] + dot <- evalExprShallow env (IVarExpr ".") + tds' <- mapM toTensor tds + let args' = Value (TensorData (Tensor s1 t1 (i1 ++ supjs))) : map (ITensor . addscript) (zip subjs tds') + applyObj env dot (map WHNF args') + else throwError $ Default "applyObj" +applyRef env (ITensor (Tensor s1 t1 i1)) refs = do + tds <- mapM evalRef refs + if length s1 > length i1 && all (\(ITensor (Tensor s _ i)) -> length s - length i == 1) tds + then do + symId <- fresh + let argnum = length tds + subjs = map (Sub . symbolScalarData symId . show) [1 .. argnum] + supjs = map (Sup . symbolScalarData symId . show) [1 .. argnum] + dot <- evalExprShallow env (IVarExpr ".") + tds' <- mapM toTensor tds + let args' = ITensor (Tensor s1 t1 (i1 ++ supjs)) : map (ITensor . addscript) (zip subjs tds') + applyObj env dot (map WHNF args') + else throwError $ Default "applyfunc" +applyRef env' (Value (Func mFuncName env names body)) refs = + mLabelFuncName mFuncName $ + if | length names == length refs -> do + evalExprShallow (extendEnv env (makeBindings' names refs)) 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 + | otherwise -> do + let (used, rest) = splitAt (length names) refs + func <- evalExprShallow (extendEnv env (makeBindings' names used)) body + applyRef env' func rest +applyRef _ (Value (CFunc env name body)) refs = do + seqRef <- liftIO . newIORef $ Sq.fromList (map IElement refs) + col <- liftIO . newIORef $ WHNF $ ICollection seqRef + evalExprShallow (extendEnv env $ makeBindings' [name] [col]) body +applyRef _ (Value (PrimitiveFunc func)) refs = do + vals <- mapM (\ref -> evalRef ref >>= evalWHNF) refs + Value <$> func vals +applyRef _ (Value (LazyPrimitiveFunc func)) refs = do + whnfs <- mapM evalRef refs + func whnfs +applyRef _ (Value (IOFunc m)) refs = do + args <- mapM evalRef refs + case args of + [Value World] -> m + arg : _ -> throwError =<< TypeMismatch "world" arg <$> getFuncNameStack +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 + return (Value (ScalarData (SingleTerm 1 [(Apply fn mExprs, 1)]))) +applyRef _ whnf _ = throwError =<< TypeMismatch "function" whnf <$> getFuncNameStack + +applyObj :: Env -> WHNFData -> [Object] -> EvalM WHNFData +applyObj env fn args = do + refs <- liftIO $ mapM newIORef args + applyRef env fn refs + +refHash :: WHNFData -> [EgisonValue] -> EvalM WHNFData +refHash val [] = return val +refHash val (index:indices) = + case val of + Value (IntHash hash) -> refHash' hash + Value (CharHash hash) -> refHash' hash + Value (StrHash hash) -> refHash' hash + IIntHash hash -> irefHash hash + ICharHash hash -> irefHash hash + IStrHash hash -> irefHash hash + _ -> throwError =<< TypeMismatch "hash" val <$> getFuncNameStack + where + refHash' hash = do + key <- fromEgison index + case HL.lookup key hash of + Just val -> refHash (Value val) indices + Nothing -> return $ Value Undefined + + irefHash hash = do + key <- fromEgison index + case HL.lookup key hash of + 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 +subst _ _ [] = [] + +newThunk :: Env -> IExpr -> Object +newThunk env expr = Thunk $ evalExprShallow env expr + +newThunkRef :: Env -> IExpr -> EvalM ObjectRef +newThunkRef env expr = liftIO . newIORef $ newThunk env expr + +recursiveBind :: Env -> [(Var, IExpr)] -> EvalM Env +recursiveBind env bindings = do + -- Create dummy bindings first. Since this is a reference, + -- it can be overwritten later. + binds <- mapM (\(var, _) -> (var,) <$> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) bindings + let env' = extendEnv env binds + forM_ bindings $ \(var, expr) -> do + let env'' = memorizeVarInEnv env' var + let ref = fromJust (refVar env' var) + liftIO $ writeIORef ref (newThunk env'' expr) + return env' + +recursiveMatchBind :: Env -> [IBindingExpr] -> EvalM Env +recursiveMatchBind env bindings = do + -- List of variables defined in |bindings| + let names = concatMap (\(pd, _) -> toList pd) bindings + -- Create dummy bindings for |names| first. Since this is a reference, + -- it can be overwritten later. + binds <- mapM (\name -> (name,) <$> newThunkRef nullEnv (IConstantExpr UndefinedExpr)) names + let env' = extendEnv env binds + forM_ bindings $ \(pd, expr) -> do + -- Modify |env'| for some cases + let env'' = case pd of + PDPatVar var -> memorizeVarInEnv env' var + _ -> env' + thunk <- newThunkRef env'' expr + binds <- bindPrimitiveDataPattern pd thunk + forM_ binds $ \(var, objref) -> do + -- |obj| is an Object being bound to |var|. + obj <- liftIO $ readIORef objref + let ref = fromJust (refVar env' var) + liftIO $ writeIORef ref obj + return env' + +memorizeVarInEnv :: Env -> Var -> Env +memorizeVarInEnv (Env frame _) (Var var is) = + Env frame (Just (var, map (fmap (const "")) is)) + +-- +-- Pattern Match +-- + +patternMatch :: PMMode -> Env -> IPattern -> WHNFData -> Matcher -> EvalM (MList EvalM Match) +patternMatch pmmode env pattern target matcher = + case pmmode of + DFSMode -> processMStatesAllDFS (msingleton initMState) + BFSMode -> processMStatesAll [msingleton initMState] + where + initMState = MState { mStateEnv = env + , loopPatCtx = [] + , seqPatCtx = [] + , mStateBindings = [] + , mTrees = [MAtom pattern target matcher] + } + +processMStatesAllDFS :: MList EvalM MatchingState -> EvalM (MList EvalM Match) +processMStatesAllDFS MNil = return MNil +processMStatesAllDFS (MCons (MState _ _ [] bindings []) ms) = MCons bindings . processMStatesAllDFS <$> ms +processMStatesAllDFS (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS + +processMStatesAllDFSForall :: MList EvalM MatchingState -> EvalM (MList EvalM MatchingState) +processMStatesAllDFSForall MNil = return MNil +processMStatesAllDFSForall (MCons mstate@(MState _ _ (ForallPatContext _ _ : _) _ []) ms) = MCons mstate . processMStatesAllDFSForall <$> ms +processMStatesAllDFSForall (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFSForall + +processMStatesAll :: [MList EvalM MatchingState] -> EvalM (MList EvalM Match) +processMStatesAll [] = return MNil +processMStatesAll streams = do + (matches, streams') <- mapM processMStates streams >>= extractMatches . concat + mappend (fromList matches) $ processMStatesAll streams' + +processMStates :: MList EvalM MatchingState -> EvalM [MList EvalM MatchingState] +processMStates MNil = return [] +processMStates (MCons state stream) = (\x y -> [x, y]) <$> processMState state <*> stream + +extractMatches :: [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState]) +extractMatches = extractMatches' ([], []) + where + extractMatches' :: ([Match], [MList EvalM MatchingState]) -> [MList EvalM MatchingState] -> EvalM ([Match], [MList EvalM MatchingState]) + extractMatches' (xs, ys) [] = return (xs, ys) + extractMatches' (xs, ys) (MCons (gatherBindings -> Just bindings) states : rest) = do + states' <- states + extractMatches' (xs ++ [bindings], ys ++ [states']) rest + extractMatches' (xs, ys) (stream:rest) = extractMatches' (xs, ys ++ [stream]) rest + +gatherBindings :: MatchingState -> Maybe [Binding] +gatherBindings MState{ seqPatCtx = [], mStateBindings = b, mTrees = [] } = return b +gatherBindings _ = Nothing + +processMState :: MatchingState -> EvalM (MList EvalM MatchingState) +processMState state | nullMState state = processMState' state +processMState state = + case splitMState state of + (1, state1, state2) -> do + result <- processMStatesAllDFS (msingleton state1) + case result of + MNil -> return $ msingleton state2 + _ -> return MNil + (0, MState e l s b [MAtom (IForallPat p1 p2) m t], MState{ mTrees = trees }) -> do + states <- processMStatesAllDFSForall (msingleton (MState e l (ForallPatContext [] []:s) b [MAtom p1 m t])) + statess' <- mmap (\(MState e' l' (ForallPatContext ms ts:s') b' []) -> do + let mat' = makeTuple ms + tgt' <- makeITuple ts + processMStatesAllDFSForall (msingleton (MState e' l' (ForallPatContext [] []:s') b' [MAtom p2 tgt' mat']))) states + b <- mAny (\case + MNil -> return True + _ -> 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' + mconcat nstatess + _ -> processMState' state + where + splitMState :: MatchingState -> (Integer, MatchingState, MatchingState) + splitMState mstate@MState{ mTrees = MAtom (INotPat pattern) target matcher : trees } = + (1, mstate { seqPatCtx = [], mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees }) + splitMState mstate@MState{ mTrees = MAtom pattern target matcher : trees } = + (0, mstate { mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees }) + splitMState mstate@MState{ mTrees = MNode penv state' : trees } = + (f, mstate { mTrees = [MNode penv state1] }, mstate { mTrees = MNode penv state2 : trees }) + 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@MState{ seqPatCtx = [], mTrees = [] } = return . msingleton $ mstate -- for forall pattern used in matchAll (not matchAllDFS) + +-- Sequential patterns and forall pattern +processMState' mstate@MState{ seqPatCtx = SeqPatContext stack ISeqNilPat [] []:seqs, mTrees = [] } = + return . msingleton $ mstate { seqPatCtx = seqs, mTrees = stack } +processMState' mstate@MState{ seqPatCtx = SeqPatContext stack seqPat mats tgts:seqs, mTrees = [] } = do + let mat' = makeTuple mats + tgt' <- makeITuple tgts + return . msingleton $ mstate { seqPatCtx = seqs, mTrees = MAtom seqPat tgt' mat' : stack } +processMState' mstate@MState{ seqPatCtx = ForallPatContext _ _:_, mTrees = [] } = + return . msingleton $ mstate + +-- Matching Nodes +--processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwError =<< EgisonBug "should not reach here (empty matching-node)" <$> getFuncNameStack +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 } = + case lookup name penv of + Just pattern -> + 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 + +processMState' ms1@(MState _ _ _ bindings (MNode penv ms2@(MState env' loops' _ _ (MAtom (IIndexedPat (IVarPat name) indices) target matcher:trees')):trees)) = + case lookup name penv of + Just pattern -> do + let env'' = extendEnvForNonLinearPatterns env' bindings loops' + indices <- mapM (evalExprDeep env'' >=> fmap fromInteger . fromEgison) indices + let pattern' = IIndexedPat pattern $ map (IConstantExpr . IntegerExpr) indices + 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 + +processMState' mstate@MState{ mTrees = MNode penv state:trees } = + processMState' state >>= mmap (\state' -> case state' of +--egi MState { mTrees = [] } -> return $ mstate { mTrees = trees } + _ -> return $ mstate { mTrees = MNode penv state':trees }) + +-- Matching Atoms +processMState' mstate@(MState env loops seqs bindings (MAtom pattern target matcher:trees)) = + let env' = extendEnvForNonLinearPatterns env bindings loops in + case pattern of + IInductiveOrPApplyPat name args -> + case refVar env (stringToVar name) of + Nothing -> processMState' (mstate { mTrees = MAtom (IInductivePat name args) target matcher:trees }) + Just ref -> do + whnf <- evalRef ref + case whnf of + Value PatternFunc{} -> + processMState' (mstate { mTrees = MAtom (IPApplyPat (IVarExpr name) args) target matcher:trees }) + _ -> + processMState' (mstate { mTrees = MAtom (IInductivePat name args) target matcher:trees }) + + INotPat _ -> throwError =<< EgisonBug "should not reach here (not-pattern)" <$> getFuncNameStack + IVarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ show pattern + + ILetPat bindings' pattern' -> do + b <- concat <$> mapM extractBindings bindings' + return . msingleton $ mstate { mStateBindings = b ++ bindings, mTrees = MAtom pattern' target matcher:trees } + where + extractBindings (pdp, expr) = do + thunk <- newThunkRef (extendEnv env bindings) expr + bindPrimitiveDataPattern pdp thunk + + IPredPat predicate -> do + func <- evalExprShallow env' predicate + result <- applyObj env func [WHNF target] >>= evalWHNF >>= fromEgison + if result then return . msingleton $ mstate { mTrees = trees } + else return MNil + + IPApplyPat func args -> do + func' <- evalExprShallow env' func + case func' of + 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 + + IDApplyPat func args -> + return . msingleton $ mstate { mTrees = MAtom (IInductivePat "apply" [func, toListPat args]) target matcher:trees } + + ILoopPat name (ILoopRange start ends endPat) pat pat' -> do + startNum <- evalExprDeep env' start >>= fromEgison :: (EvalM Integer) + startNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum - 1) + ends' <- evalExprShallow env' ends + case ends' of + Value (ScalarData _) -> do -- the case when the end numbers are an integer + endsRef <- newEvaluatedObjectRef ends' + inners <- liftIO . newIORef $ Sq.fromList [IElement endsRef] + endsRef' <- liftIO $ newIORef (WHNF (ICollection inners)) + return . msingleton $ mstate { loopPatCtx = LoopPatContext (name, startNumRef) endsRef' endPat pat pat':loops + , mTrees = MAtom IContPat target matcher:trees } + _ -> do -- the case when the end numbers are a collection + endsRef <- newEvaluatedObjectRef ends' + return . msingleton $ mstate { loopPatCtx = LoopPatContext (name, startNumRef) endsRef endPat pat pat':loops + , mTrees = MAtom IContPat target matcher:trees } + IContPat -> + case loops of + [] -> throwError $ Default "cannot use cont pattern except in loop pattern" + LoopPatContext (name, startNumRef) endsRef endPat pat pat' : loops' -> do + startNumVal <- evalRefDeep startNumRef + startNum <- fromEgison startNumVal :: (EvalM Integer) + nextNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum + 1) + ends <- evalRef endsRef + b <- isEmptyCollection ends + if b + then return MNil + else do + (carEndsRef, cdrEndsRef) <- fromJust <$> runMaybeT (unconsCollection ends) + b2 <- evalRef cdrEndsRef >>= isEmptyCollection + carEndsNum <- evalRefDeep carEndsRef >>= fromEgison + return $ if + | startNum > carEndsNum -> MNil + | startNum == carEndsNum && b2 -> + fromList [mstate { loopPatCtx = loops', mTrees = MAtom endPat (Value startNumVal) Something:MAtom pat' target matcher:trees }] + | startNum == carEndsNum -> + fromList [mstate { loopPatCtx = loops', mTrees = MAtom endPat (Value startNumVal) Something:MAtom pat' target matcher:trees }, + mstate { loopPatCtx = LoopPatContext (name, nextNumRef) cdrEndsRef endPat pat pat':loops', mTrees = MAtom pat target matcher:trees }] + | otherwise -> + fromList [mstate { 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 + ISeqConsPat pattern pattern' -> return . msingleton $ MState env loops (SeqPatContext trees pattern' [] []:seqs) bindings [MAtom pattern target matcher] + ILaterPatVar -> + case seqs of + [] -> throwError $ Default "cannot use # out of seq patterns" + SeqPatContext stack pat mats tgts:seqs -> + return . msingleton $ MState env loops (SeqPatContext stack pat (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees + ForallPatContext mats tgts:seqs -> + return . msingleton $ MState env loops (ForallPatContext (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees + IAndPat pat1 pat2 -> + let trees' = [MAtom pat1 target matcher, MAtom pat2 target matcher] ++ trees + in return . msingleton $ mstate { mTrees = trees' } + IOrPat pat1 pat2 -> + return $ fromList [mstate { mTrees = MAtom pat1 target matcher : trees }, mstate { mTrees = MAtom pat2 target matcher : trees }] + + _ -> + case matcher of + UserMatcher{} -> do + (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher + case length patterns of + 1 -> + mfor targetss $ \ref -> do + targets <- evalRef ref >>= (\x -> return [x]) + let trees' = zipWith3 MAtom patterns targets matchers ++ trees + return $ mstate { mTrees = trees' } + _ -> + mfor targetss $ \ref -> do + targets <- evalRef ref >>= tupleToListWHNF + let trees' = zipWith3 MAtom patterns targets matchers ++ trees + return $ mstate { mTrees = trees' } + + Tuple matchers -> + case pattern of + IValuePat _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees } + IWildCard -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees } + IPatVar _ -> return . msingleton $ mstate { mTrees = MAtom pattern target Something:trees } + 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 + 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 + + Something -> + case pattern of + IValuePat valExpr -> do + val <- evalExprDeep env' valExpr + tgtVal <- evalWHNF target + if val == tgtVal + then return . msingleton $ mstate { mTrees = trees } + else return MNil + IWildCard -> return . msingleton $ mstate { mTrees = trees } + IPatVar name -> do + targetRef <- newEvaluatedObjectRef target + return . msingleton $ mstate { mStateBindings = (stringToVar name, targetRef):bindings, mTrees = trees } + IIndexedPat (IPatVar name') indices -> do + let name = stringToVar name' + indices <- mapM (evalExprDeep env' >=> fmap fromInteger . fromEgison) indices + case lookup name bindings of + Just ref -> do + 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 + 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 + 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 + +inductiveMatch :: Env -> IPattern -> WHNFData -> Matcher -> + EvalM ([IPattern], MList EvalM ObjectRef, [Matcher]) +inductiveMatch env pattern target (UserMatcher matcherEnv clauses) = + foldr tryPPMatchClause failPPPatternMatch clauses + where + tryPPMatchClause (pat, matchers, clauses) cont = do + result <- runMaybeT $ primitivePatPatternMatch env pat pattern + case result of + Just ([pattern], bindings) -> do + targetss <- foldr (tryPDMatchClause bindings) failPDPatternMatch clauses + matcher <- evalExprShallow matcherEnv matchers >>= evalMatcherWHNF + return ([pattern], targetss, [matcher]) + Just (patterns, bindings) -> do + targetss <- foldr (tryPDMatchClause bindings) failPDPatternMatch clauses + matchers <- tupleToList <$> (evalExprShallow matcherEnv matchers >>= evalMatcherWHNF) + return (patterns, targetss, matchers) + _ -> cont + tryPDMatchClause bindings (pat, expr) cont = do + ref <- newEvaluatedObjectRef target + result <- runMaybeT $ primitiveDataPatternMatch pat ref + case result of + Just bindings' -> do + let env = extendEnv matcherEnv $ bindings ++ bindings' + evalExprShallow env expr >>= collectionToRefs + _ -> cont + failPPPatternMatch = throwError (Default "failed primitive pattern pattern match") + failPDPatternMatch = throwError =<< PrimitiveMatchFailure <$> getFuncNameStack + +primitivePatPatternMatch :: Env -> PrimitivePatPattern -> IPattern -> + MatchM ([IPattern], [Binding]) +primitivePatPatternMatch _ PPWildCard IWildCard = return ([], []) +primitivePatPatternMatch _ PPPatVar pattern = return ([pattern], []) +primitivePatPatternMatch env (PPValuePat name) (IValuePat expr) = do + ref <- lift $ newThunkRef env expr + return ([], [(stringToVar name, ref)]) +primitivePatPatternMatch env (PPInductivePat name patterns) (IInductivePat name' exprs) + | name == name' && length patterns == length exprs = + (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs + | otherwise = matchFail +primitivePatPatternMatch env (PPTuplePat patterns) (ITuplePat exprs) + | length patterns == length exprs = + (concat *** concat) . unzip <$> zipWithM (primitivePatPatternMatch env) patterns exprs + | otherwise = matchFail +primitivePatPatternMatch _ _ _ = matchFail + +bindPrimitiveDataPattern :: IPrimitiveDataPattern -> ObjectRef -> EvalM [Binding] +bindPrimitiveDataPattern pdp ref = do + r <- runMaybeT $ primitiveDataPatternMatch pdp ref + case r of + Nothing -> throwError =<< PrimitiveMatchFailure <$> getFuncNameStack + Just binding -> return binding + +primitiveDataPatternMatch :: IPrimitiveDataPattern -> ObjectRef -> MatchM [Binding] +primitiveDataPatternMatch PDWildCard _ = return [] +primitiveDataPatternMatch (PDPatVar name) ref = return [(name, ref)] +primitiveDataPatternMatch (PDInductivePat name patterns) ref = do + whnf <- lift $ evalRef ref + case whnf of + IInductiveData name' refs | name == name' -> + concat <$> zipWithM primitiveDataPatternMatch patterns refs + Value (InductiveData name' vals) | name == name' -> do + whnfs <- lift $ mapM (newEvaluatedObjectRef . Value) vals + concat <$> zipWithM primitiveDataPatternMatch patterns whnfs + _ -> matchFail +primitiveDataPatternMatch (PDTuplePat patterns) ref = do + whnf <- lift $ evalRef ref + case whnf of + ITuple refs -> do + concat <$> zipWithM primitiveDataPatternMatch patterns refs + Value (Tuple vals) -> do + whnfs <- lift $ mapM (newEvaluatedObjectRef . Value) vals + concat <$> zipWithM primitiveDataPatternMatch patterns whnfs + _ -> matchFail +primitiveDataPatternMatch PDEmptyPat ref = do + whnf <- lift $ evalRef ref + isEmpty <- lift $ isEmptyCollection whnf + if isEmpty then return [] else matchFail +primitiveDataPatternMatch (PDConsPat pattern pattern') ref = do + whnf <- lift $ evalRef ref + (head, tail) <- unconsCollection whnf + (++) <$> primitiveDataPatternMatch pattern head + <*> primitiveDataPatternMatch pattern' tail +primitiveDataPatternMatch (PDSnocPat pattern pattern') ref = do + whnf <- lift $ evalRef ref + (init, last) <- unsnocCollection whnf + (++) <$> primitiveDataPatternMatch pattern init + <*> primitiveDataPatternMatch pattern' last +primitiveDataPatternMatch (PDConstantPat expr) ref = do + whnf <- lift $ evalRef ref + case whnf of + Value val | val == evalConstant expr -> return [] + _ -> matchFail + +extendEnvForNonLinearPatterns :: Env -> [Binding] -> [LoopPatContext] -> Env +extendEnvForNonLinearPatterns env bindings loops = extendEnv env $ bindings ++ map (\(LoopPatContext (name, ref) _ _ _ _) -> (stringToVar name, ref)) loops + +evalMatcherWHNF :: WHNFData -> EvalM Matcher +evalMatcherWHNF (Value matcher@Something) = return matcher +evalMatcherWHNF (Value matcher@UserMatcher{}) = return matcher +evalMatcherWHNF (Value (Tuple ms)) = Tuple <$> mapM (evalMatcherWHNF . Value) ms +evalMatcherWHNF (ITuple refs) = do + whnfs <- mapM evalRef refs + ms <- mapM evalMatcherWHNF whnfs + return $ Tuple ms +evalMatcherWHNF whnf = throwError =<< TypeMismatch "matcher" whnf <$> getFuncNameStack + +-- +-- Util +-- +toListPat :: [IPattern] -> IPattern +toListPat [] = IInductivePat "nil" [] +toListPat (pat:pats) = IInductivePat "::" [pat, toListPat pats] + +makeITensorFromWHNF :: Shape -> [WHNFData] -> EvalM WHNFData +makeITensorFromWHNF s xs = do + xs' <- mapM newEvaluatedObjectRef xs + return $ ITensor (Tensor s (V.fromList xs') []) + +newITensor :: Shape -> [ObjectRef] -> WHNFData +newITensor s refs = ITensor (Tensor s (V.fromList refs) []) + +-- Refer the specified tensor index with potential overriding of the index. +refTensorWithOverride :: TensorComponent a b => Bool -> [Index EgisonValue] -> Tensor b -> EvalM a +refTensorWithOverride override js (Tensor ns xs is) = + tref js' (Tensor ns xs js') >>= tContract' >>= fromTensor where js' = if override then js else is ++ js 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,12 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuasiQuotes #-} {- | Module : Language.Egison.Data @@ -21,11 +16,11 @@ EgisonValue (..) , Matcher , PrimitiveFunc + , LazyPrimitiveFunc , EgisonHashKey (..) , EgisonData (..) , Tensor (..) , Shape - , HasTensor (..) -- * Scalar , symbolScalarData , symbolScalarData' @@ -34,45 +29,29 @@ , mathExprToEgison , egisonToScalarData , extractScalar - , extractScalar' - -- * Tensor - , tensorToWHNF - , tensorToValue -- * Internal data , Object (..) , ObjectRef , WHNFData (..) - , Intermediate (..) , Inner (..) - , EgisonWHNF (..) -- * Environment , Env (..) , Binding , nullEnv , extendEnv , refVar - -- * Pattern matching - , Match - , MatchingTree (..) - , MatchingState (..) - , PatternBinding - , LoopPatContext (..) - , SeqPatContext (..) -- * Errors , EgisonError (..) -- * Monads - , EvalM (..) + , EvalM , fromEvalM - , MatchM - , matchFail + , fromEvalT ) where import Control.Exception -import Data.Typeable import Control.Monad.Except hiding (join) -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.State +import Control.Monad.Trans.State.Strict import Data.Foldable (toList) import Data.HashMap.Strict (HashMap) @@ -84,23 +63,23 @@ import Data.List (intercalate) import Data.Text (Text) +import Text.Show.Unicode (ushow) import Data.Ratio import System.IO -import Control.Egison hiding (Integer, MList, MNil, MCons, Matcher, Something, mappend) -import qualified Control.Egison as M - -import Language.Egison.AST hiding (PatVar) -import Language.Egison.IState -import Language.Egison.MathExpr +import Language.Egison.CmdOptions +import Language.Egison.EvalState +import Language.Egison.IExpr +import Language.Egison.Math +import Language.Egison.RState -- -- Values -- -data EgisonValue = - World +data EgisonValue + = World | Char Char | String Text | Bool Bool @@ -113,13 +92,13 @@ | IntHash (HashMap Integer EgisonValue) | CharHash (HashMap Char EgisonValue) | StrHash (HashMap Text EgisonValue) - | UserMatcher Env [PatternDef] - | Func (Maybe Var) Env [String] EgisonExpr - | AnonParamFunc Env Integer EgisonExpr - | CFunc (Maybe Var) Env String EgisonExpr - | MemoizedFunc (Maybe Var) ObjectRef (IORef (HashMap [Integer] ObjectRef)) Env [String] EgisonExpr - | PatternFunc Env [String] EgisonPattern - | PrimitiveFunc String PrimitiveFunc + | UserMatcher Env [IPatternDef] + | Func (Maybe String) Env [String] IExpr + | CFunc Env String IExpr + | MemoizedFunc (IORef (HashMap [Integer] WHNFData)) Env [String] IExpr + | PatternFunc Env [String] IPattern + | PrimitiveFunc PrimitiveFunc + | LazyPrimitiveFunc LazyPrimitiveFunc | IOFunc (EvalM WHNFData) | Port Handle | RefBox (IORef EgisonValue) @@ -128,10 +107,11 @@ type Matcher = EgisonValue -type PrimitiveFunc = WHNFData -> EvalM WHNFData +type PrimitiveFunc = [EgisonValue] -> EvalM EgisonValue +type LazyPrimitiveFunc = [WHNFData] -> EvalM WHNFData -data EgisonHashKey = - IntKey Integer +data EgisonHashKey + = IntKey Integer | CharKey Char | StrKey Text @@ -139,41 +119,13 @@ -- Scalar and Tensor Types -- -data Tensor a = - Tensor Shape (V.Vector a) [Index EgisonValue] +data Tensor a + = Tensor Shape (V.Vector a) [Index EgisonValue] | Scalar a - deriving (Show) + deriving Show type Shape = [Integer] -class HasTensor a where - tensorElems :: a -> V.Vector a - tensorShape :: a -> Shape - tensorIndices :: a -> [Index EgisonValue] - fromTensor :: Tensor a -> EvalM a - toTensor :: a -> EvalM (Tensor a) - undef :: a - -instance HasTensor EgisonValue where - tensorElems (TensorData (Tensor _ xs _)) = xs - tensorShape (TensorData (Tensor ns _ _)) = ns - tensorIndices (TensorData (Tensor _ _ js)) = js - fromTensor t@Tensor{} = return $ TensorData t - fromTensor (Scalar x) = return x - toTensor (TensorData t) = return t - toTensor x = return $ Scalar x - undef = Undefined - -instance HasTensor WHNFData where - tensorElems (Intermediate (ITensor (Tensor _ xs _))) = xs - tensorShape (Intermediate (ITensor (Tensor ns _ _))) = ns - tensorIndices (Intermediate (ITensor (Tensor _ _ js))) = js - fromTensor t@Tensor{} = return $ Intermediate $ ITensor t - fromTensor (Scalar x) = return x - toTensor (Intermediate (ITensor t)) = return t - toTensor x = return $ Scalar x - undef = Value Undefined - -- -- Scalars -- @@ -181,11 +133,11 @@ symbolScalarData :: String -> String -> EgisonValue symbolScalarData id name = ScalarData (SingleTerm 1 [(Symbol id name [], 1)]) -symbolScalarData' :: String -> String -> ScalarData -symbolScalarData' id name = SingleTerm 1 [(Symbol id name [], 1)] +symbolScalarData' :: String -> ScalarData +symbolScalarData' name = SingleTerm 1 [(Symbol "" name [], 1)] getSymId :: EgisonValue -> String -getSymId (ScalarData (SingleTerm 1 [(Symbol id _ [], 1)])) = id +getSymId (ScalarData (SingleTerm 1 [(Symbol id _ _, _)])) = id getSymName :: EgisonValue -> String getSymName (ScalarData (SingleTerm 1 [(Symbol _ name [], 1)])) = name @@ -211,10 +163,11 @@ f js = Collection (Sq.fromList (map scalarIndexToEgison js)) scalarIndexToEgison :: Index ScalarData -> EgisonValue -scalarIndexToEgison (Superscript k) = InductiveData "Sup" [ScalarData k] -scalarIndexToEgison (Subscript k) = InductiveData "Sub" [ScalarData k] -scalarIndexToEgison (Userscript 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 egisonToScalarData (InductiveData "Div" [p1, p2]) = Div <$> egisonToPolyExpr p1 <*> egisonToPolyExpr p2 egisonToScalarData p1@(InductiveData "Plus" _) = Div <$> egisonToPolyExpr p1 <*> return (Plus [Term 1 []]) @@ -272,9 +225,9 @@ egisonToScalarIndex :: EgisonValue -> EvalM (Index ScalarData) egisonToScalarIndex j = case j of - InductiveData "Sup" [ScalarData k] -> return (Superscript k) - InductiveData "Sub" [ScalarData k] -> return (Subscript k) - InductiveData "User" [ScalarData k] -> return (Userscript k) + 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 -- @@ -285,27 +238,11 @@ extractScalar (ScalarData mExpr) = return mExpr extractScalar val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack -extractScalar' :: WHNFData -> EvalM ScalarData -extractScalar' (Value (ScalarData x)) = return x -extractScalar' val = throwError =<< TypeMismatch "integer or string" val <$> getFuncNameStack - --- --- Tensor --- - -tensorToWHNF :: Tensor WHNFData -> WHNFData -tensorToWHNF (Scalar whnf) = whnf -tensorToWHNF t@(Tensor _ _ _) = Intermediate (ITensor t) - -tensorToValue :: Tensor EgisonValue -> EgisonValue -tensorToValue (Scalar val) = val -tensorToValue t@(Tensor _ _ _) = TensorData t - -- New-syntax version of EgisonValue pretty printer. -- TODO(momohatt): Don't make it a show instance of EgisonValue. instance Show EgisonValue where show (Char c) = '\'' : c : "'" - show (String str) = show str + show (String str) = ushow str show (Bool True) = "True" show (Bool False) = "False" show (ScalarData mExpr) = show mExpr @@ -314,7 +251,7 @@ show (TensorData (Tensor [_, j] xs js)) = "[| " ++ intercalate ", " (f (fromIntegral j) (V.toList xs)) ++ " |]" ++ concatMap show js where f _ [] = [] - f j xs = ["[| " ++ intercalate ", " (map show (take j xs)) ++ " |]"] ++ f j (drop j xs) + f j xs = ("[| " ++ intercalate ", " (map show (take j xs)) ++ " |]") : f j (drop j xs) show (TensorData (Tensor ns xs js)) = "(tensor [" ++ intercalate ", " (map show ns) ++ "] [" ++ intercalate ", " (map show (V.toList xs)) ++ "] )" ++ concatMap show js show (Float x) = show x show (InductiveData name vals) = name ++ concatMap ((' ':) . show') vals @@ -327,17 +264,15 @@ show (CharHash hash) = "{|" ++ intercalate ", " (map (\(key, val) -> "[" ++ show key ++ ", " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show (StrHash hash) = "{|" ++ intercalate ", " (map (\(key, val) -> "[" ++ show key ++ ", " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}" show UserMatcher{} = "#" - show (Func Nothing _ args _) = "(lambda [" ++ intercalate ", " (map show args) ++ "] ...)" - show (Func (Just name) _ _ _) = show name - show (AnonParamFunc _ n expr) = show n ++ "#" ++ show expr - show (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)" - show (CFunc (Just name) _ _ _) = show name - show (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ intercalate ", " names ++ "] ...)" - show (MemoizedFunc (Just name) _ _ _ _ _) = show name + show (Func _ _ args _) = "#" + show (CFunc _ name _) = "#" + show (MemoizedFunc _ _ names _) = "#" show PatternFunc{} = "#" - show (PrimitiveFunc name _) = "#" - show (IOFunc _) = "#" - show (Port _) = "#" + show PrimitiveFunc{} = "#" + show LazyPrimitiveFunc{} = "#" + show IOFunc{} = "#" + show Port{} = "#" + show RefBox{} = "#" show Something = "something" show Undefined = "undefined" show World = "#" @@ -350,25 +285,21 @@ 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 - (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' - (PrimitiveFunc name1 _) == (PrimitiveFunc name2 _) = name1 == name2 - -- Temporary: searching a better solution - (Func Nothing _ xs1 expr1) == (Func Nothing _ xs2 expr2) = (xs1 == xs2) && (expr1 == expr2) - (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _) = name1 == name2 - (CFunc Nothing _ x1 expr1) == (CFunc Nothing _ x2 expr2) = (x1 == x2) && (expr1 == expr2) - (CFunc (Just name1) _ _ _) == (CFunc (Just name2) _ _ _) = name1 == name2 - _ == _ = False + (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' + -- Temporary: searching a better solution + (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _) = name1 == name2 + _ == _ = False -- -- Egison data and Haskell data @@ -393,8 +324,8 @@ fromEgison val = throwError =<< TypeMismatch "bool" (Value val) <$> getFuncNameStack instance EgisonData Integer where - toEgison 0 = ScalarData $ mathNormalize' (Div (Plus []) (Plus [Term 1 []])) - toEgison i = ScalarData $ mathNormalize' (SingleTerm i []) + 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 @@ -461,37 +392,34 @@ -- |For memoization type ObjectRef = IORef Object -data Object = - Thunk (EvalM WHNFData) +data Object + = Thunk (EvalM WHNFData) | WHNF WHNFData -data WHNFData = - Intermediate Intermediate - | Value EgisonValue - -data Intermediate = - IInductiveData String [ObjectRef] +data WHNFData + = Value EgisonValue + | IInductiveData String [ObjectRef] | ITuple [ObjectRef] | ICollection (IORef (Seq Inner)) | IIntHash (HashMap Integer ObjectRef) | ICharHash (HashMap Char ObjectRef) | IStrHash (HashMap Text ObjectRef) - | ITensor (Tensor WHNFData) + | ITensor (Tensor ObjectRef) -data Inner = - IElement ObjectRef +data Inner + = IElement ObjectRef | ISubCollection ObjectRef instance Show WHNFData where show (Value val) = show val - show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>" - show (Intermediate (ITuple _)) = "[...]" - show (Intermediate (ICollection _)) = "{...}" - show (Intermediate (IIntHash _)) = "{|...|}" - show (Intermediate (ICharHash _)) = "{|...|}" - show (Intermediate (IStrHash _)) = "{|...|}" - show (Intermediate (ITensor (Tensor ns xs _))) = "[|" ++ show (length ns) ++ show (V.length xs) ++ "|]" - show (Intermediate (ITensor (Scalar _))) = "scalar" + 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" instance Show Object where show (Thunk _) = "#" @@ -501,105 +429,38 @@ show _ = "#" -- --- Extract data from WHNF --- -class EgisonData a => EgisonWHNF a where - toWHNF :: a -> WHNFData - fromWHNF :: WHNFData -> EvalM a - toWHNF = Value . toEgison - -instance EgisonWHNF Char where - fromWHNF (Value (Char c)) = return c - fromWHNF whnf = throwError =<< TypeMismatch "char" whnf <$> getFuncNameStack - -instance EgisonWHNF Text where - fromWHNF (Value (String str)) = return str - fromWHNF whnf = throwError =<< TypeMismatch "string" whnf <$> getFuncNameStack - -instance EgisonWHNF Bool where - fromWHNF (Value (Bool b)) = return b - fromWHNF whnf = throwError =<< TypeMismatch "bool" whnf <$> getFuncNameStack - -instance EgisonWHNF Integer where - fromWHNF (Value (ScalarData (Div (Plus []) (Plus [Term 1 []])))) = return 0 - fromWHNF (Value (ScalarData (SingleTerm x []))) = return x - fromWHNF whnf = throwError =<< TypeMismatch "integer" whnf <$> getFuncNameStack - -instance EgisonWHNF Double where - fromWHNF (Value (Float f)) = return f - fromWHNF whnf = throwError =<< TypeMismatch "float" whnf <$> getFuncNameStack - -instance EgisonWHNF Handle where - fromWHNF (Value (Port h)) = return h - fromWHNF whnf = throwError =<< TypeMismatch "port" whnf <$> getFuncNameStack - --- -- Environment -- -data Env = Env [HashMap Var ObjectRef] (Maybe VarWithIndices) - deriving (Show) +data Env = Env [HashMap Var ObjectRef] (Maybe (String, [Index String])) type Binding = (Var, ObjectRef) -instance Show (Index EgisonValue) where - show (Superscript i) = case i of +instance {-# OVERLAPPING #-} Show (Index EgisonValue) where + show (Sup i) = case i of ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "~[" ++ show i ++ "]" _ -> "~" ++ show i - show (Subscript i) = case i of + show (Sub i) = case i of ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]" _ -> "_" ++ show i - show (SupSubscript i) = "~_" ++ show i - show (DFscript i j) = "_d" ++ show i ++ show j - show (Userscript i) = case i of + show (SupSub i) = "~_" ++ show i + show (User i) = case i of ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]" _ -> "|" ++ show i + show (DF i j) = "_d" ++ show i ++ show j nullEnv :: Env nullEnv = Env [] Nothing extendEnv :: Env -> [Binding] -> Env -extendEnv (Env env idx) bdg = Env ((: env) $ HashMap.fromList bdg) idx +extendEnv (Env env idx) bdg = Env (HashMap.fromList bdg : env) idx refVar :: Env -> Var -> Maybe ObjectRef refVar (Env env _) var@(Var _ []) = msum $ map (HashMap.lookup var) env refVar e@(Env env _) var@(Var name is) = case msum $ map (HashMap.lookup var) env of - Nothing -> match is (List M.Something) - [[mc| $his ++ _ : [] -> refVar e (Var name his) |]] - Just x -> Just x - --- --- Pattern Match --- - -type Match = [Binding] - -data MatchingState - = MState { mStateEnv :: Env - , loopPatCtx :: [LoopPatContext] - , seqPatCtx :: [SeqPatContext] - , mStateBindings :: [Binding] - , mTrees :: [MatchingTree] - } - -instance Show MatchingState where - show ms = "(MState " ++ unwords ["_", "_", "_", show (mStateBindings ms), show (mTrees ms)] ++ ")" - -data MatchingTree = - MAtom EgisonPattern WHNFData Matcher - | MNode [PatternBinding] MatchingState - deriving (Show) - -type PatternBinding = (String, EgisonPattern) - -data LoopPatContext = LoopPatContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern - deriving (Show) - -data SeqPatContext = - SeqPatContext [MatchingTree] EgisonPattern [Matcher] [WHNFData] - | ForallPatContext [Matcher] [WHNFData] - deriving (Show) + Nothing -> refVar e (Var name (init is)) + Just x -> Just x -- -- Errors @@ -607,11 +468,10 @@ type CallStack = [String] -data EgisonError = - UnboundVariable String CallStack +data EgisonError + = UnboundVariable String CallStack | TypeMismatch String WHNFData CallStack - | ArgumentsNumWithNames [String] Int Int CallStack - | ArgumentsNumPrimitive Int Int CallStack + | ArgumentsNumPrimitive String Int Int CallStack | TupleLength Int Int CallStack | InconsistentTensorShape CallStack | InconsistentTensorIndex CallStack @@ -620,20 +480,17 @@ | Assertion String CallStack | Parser String | EgisonBug String CallStack - | MatchFailure String CallStack - | UnknownFileExtension String + | MatchFailure CallStack + | PrimitiveMatchFailure CallStack | Default String - deriving Typeable instance Show EgisonError where show (UnboundVariable var stack) = "Unbound variable: " ++ show var ++ showTrace stack show (TypeMismatch expected found stack) = "Expected " ++ expected ++ ", but found: " ++ show found ++ showTrace stack - show (ArgumentsNumWithNames names expected got stack) = - "Wrong number of arguments: " ++ show names ++ ": expected " ++ show expected ++ ", but got " ++ show got ++ showTrace stack - show (ArgumentsNumPrimitive expected got stack) = - "Wrong number of arguments for a primitive function: expected " ++ show expected ++ ", but got " ++ show got ++ showTrace stack + show (ArgumentsNumPrimitive name expected got stack) = + "Wrong number of arguments for a primitive function '" ++ name ++ "': expected " ++ show expected ++ ", but got " ++ show got ++ showTrace stack show (TupleLength expected got stack) = "Inconsistent tuple lengths: expected " ++ show expected ++ ", but got " ++ show got ++ showTrace stack show (InconsistentTensorShape stack) = "Inconsistent tensor shape" ++ showTrace stack @@ -643,11 +500,8 @@ show (Assertion message stack) = "Assertion failed: " ++ message ++ showTrace stack show (Parser err) = "Parse error at: " ++ err show (EgisonBug message stack) = "Egison Error: " ++ message ++ showTrace stack - show (MatchFailure currentFunc stack) = "Failed pattern match in: " ++ currentFunc ++ showTrace stack - show (UnknownFileExtension name) = - "Unknown file extension: " ++ name ++ - "\nFile name should be suffixed with either \".egi\" (for Haskell-like syntax)" ++ - " or \".segi\" (for S-expression syntax)" + show (MatchFailure stack) = "Pattern match failed" ++ showTrace stack + show (PrimitiveMatchFailure stack) = "Primitive data pattern match failed" ++ showTrace stack show (Default message) = "Error: " ++ message showTrace :: CallStack -> String @@ -659,35 +513,18 @@ -- Monads -- -newtype EvalM a = EvalM { - unEvalM :: StateT IState (ExceptT EgisonError IO) a - } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError) +type EvalT m = StateT EvalState (ExceptT EgisonError m) -instance MonadFail EvalM where - fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack +type EvalM = EvalT RuntimeM -instance MonadEval EvalM where - fresh = EvalM $ do - st <- get; modify (\st -> st { indexCounter = indexCounter st + 1 }) - return $ "$_" ++ show (indexCounter st) - freshV = EvalM $ do - st <- get; modify (\st -> st {indexCounter = indexCounter st + 1 }) - return $ Var ["$_" ++ show (indexCounter st)] [] - pushFuncName name = EvalM $ do - st <- get - put $ st { funcNameStack = name : funcNameStack st } - return () - topFuncName = EvalM $ head . funcNameStack <$> get - popFuncName = EvalM $ do - st <- get - put $ st { funcNameStack = tail $ funcNameStack st } - return () - getFuncNameStack = EvalM $ funcNameStack <$> get +instance {-# OVERLAPPING #-} MonadFail EvalM where + fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack -fromEvalM :: EvalM a -> IO (Either EgisonError a) -fromEvalM = runExceptT . modifyCounter . unEvalM +instance MonadRuntime EvalM where + fresh = lift $ lift fresh -type MatchM = MaybeT EvalM +fromEvalT :: EvalM a -> RuntimeM (Either EgisonError a) +fromEvalT m = runExceptT (evalStateT m initialEvalState) -matchFail :: MatchM a -matchFail = MaybeT $ return Nothing +fromEvalM :: EgisonOpts -> EvalM a -> IO (Either EgisonError a) +fromEvalM opts = evalRuntimeT opts . fromEvalT diff --git a/hs-src/Language/Egison/Data/Collection.hs b/hs-src/Language/Egison/Data/Collection.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Data/Collection.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE TupleSections #-} + +{- | +Module : Language.Egison.Data.Collection +Licence : MIT + +This module provides some helper functions that operates on / returns +collections. +-} + +module Language.Egison.Data.Collection + ( expandCollection + , isEmptyCollection + , unconsCollection + , unsnocCollection + , collectionToRefs + , collectionToList + , makeICollection + ) where + +import Control.Monad.Except (throwError, lift, liftIO) +import Control.Monad.Trans.Maybe (runMaybeT) + +import Data.Foldable (toList) +import Data.IORef +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 + +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 + +isEmptyCollection :: WHNFData -> EvalM Bool +isEmptyCollection (Value (Collection col)) = return $ Sq.null col +isEmptyCollection coll@(ICollection innersRef) = do + inners <- liftIO $ readIORef innersRef + case Sq.viewl inners of + EmptyL -> return True + ISubCollection ref' :< tInners -> do + hInners <- evalRef ref' >>= expandCollection + liftIO $ writeIORef innersRef (hInners >< tInners) + isEmptyCollection coll + _ -> return False +isEmptyCollection _ = return False + +unconsCollection :: WHNFData -> MatchM (ObjectRef, ObjectRef) +unconsCollection (Value (Collection col)) = + case Sq.viewl col of + EmptyL -> matchFail + val :< vals -> + lift $ (,) <$> newEvaluatedObjectRef (Value val) + <*> newEvaluatedObjectRef (Value $ Collection vals) +unconsCollection coll@(ICollection innersRef) = do + inners <- liftIO $ readIORef innersRef + case Sq.viewl inners of + EmptyL -> matchFail + IElement ref' :< tInners -> do + tInnersRef <- liftIO $ newIORef tInners + lift $ (ref', ) <$> newEvaluatedObjectRef (ICollection tInnersRef) + ISubCollection ref' :< tInners -> do + hInners <- lift $ evalRef ref' >>= expandCollection + liftIO $ writeIORef innersRef (hInners >< tInners) + unconsCollection coll +unconsCollection _ = matchFail + +unsnocCollection :: WHNFData -> MatchM (ObjectRef, ObjectRef) +unsnocCollection (Value (Collection col)) = + case Sq.viewr col of + EmptyR -> matchFail + vals :> val -> + lift $ (,) <$> newEvaluatedObjectRef (Value $ Collection vals) + <*> newEvaluatedObjectRef (Value val) +unsnocCollection coll@(ICollection innersRef) = do + inners <- liftIO $ readIORef innersRef + case Sq.viewr inners of + EmptyR -> matchFail + hInners :> IElement ref' -> do + hInnersRef <- liftIO $ newIORef hInners + lift $ (, ref') <$> newEvaluatedObjectRef (ICollection hInnersRef) + hInners :> ISubCollection ref' -> do + tInners <- lift $ evalRef ref' >>= expandCollection + liftIO $ writeIORef innersRef (hInners >< tInners) + unsnocCollection coll +unsnocCollection _ = matchFail + +collectionToRefs :: WHNFData -> EvalM (MList EvalM ObjectRef) +collectionToRefs (Value (Collection vals)) = + if Sq.null vals then return MNil + else fromSeq <$> mapM (newEvaluatedObjectRef . Value) vals +collectionToRefs whnf@(ICollection _) = do + isEmpty <- isEmptyCollection whnf + if isEmpty + then return MNil + else do + (head, tail) <- fromJust <$> runMaybeT (unconsCollection whnf) + tail' <- evalRef tail + return $ MCons head (collectionToRefs tail') +collectionToRefs whnf = throwError =<< TypeMismatch "collection" whnf <$> getFuncNameStack + +collectionToList :: EgisonValue -> EvalM [EgisonValue] +collectionToList (Collection sq) = return $ toList sq +collectionToList val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack + +makeICollection :: [WHNFData] -> EvalM WHNFData +makeICollection xs = do + is <- mapM (\x -> IElement <$> newEvaluatedObjectRef x) xs + v <- liftIO $ newIORef $ Sq.fromList is + return $ ICollection v diff --git a/hs-src/Language/Egison/Data/Utils.hs b/hs-src/Language/Egison/Data/Utils.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Data/Utils.hs @@ -0,0 +1,78 @@ +{- | +Module : Language.Egison.Data.Utils +Licence : MIT + +This module provides some helper functions for handling Egison data. +-} + +module Language.Egison.Data.Utils + ( evalRef + , evalObj + , writeObjectRef + , newEvaluatedObjectRef + , makeBindings + , makeBindings' + , tupleToRefs + , tupleToListWHNF + , tupleToList + , makeTuple + , makeITuple + ) where + +import Control.Monad.State (liftIO) + +import Data.IORef + +import Language.Egison.Data +import Language.Egison.IExpr (Var, stringToVar) + + +evalRef :: ObjectRef -> EvalM WHNFData +evalRef ref = do + obj <- liftIO $ readIORef ref + case obj of + WHNF val -> return val + Thunk thunk -> do + val <- thunk + writeObjectRef ref val + return val + +evalObj :: Object -> EvalM WHNFData +evalObj (WHNF val) = return val +evalObj (Thunk thunk) = thunk + +writeObjectRef :: ObjectRef -> WHNFData -> EvalM () +writeObjectRef ref val = liftIO . writeIORef ref $ WHNF val + +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 (Value (Tuple vals)) = mapM (newEvaluatedObjectRef . Value) vals +tupleToRefs whnf = return <$> newEvaluatedObjectRef whnf + +tupleToListWHNF :: WHNFData -> EvalM [WHNFData] +tupleToListWHNF (ITuple refs) = mapM evalRef refs +tupleToListWHNF (Value (Tuple vals)) = return $ map Value vals +tupleToListWHNF whnf = return [whnf] + +tupleToList :: EgisonValue -> [EgisonValue] +tupleToList (Tuple vals) = vals +tupleToList val = [val] + +makeTuple :: [EgisonValue] -> EgisonValue +makeTuple [] = Tuple [] +makeTuple [x] = x +makeTuple xs = Tuple xs + +makeITuple :: [WHNFData] -> EvalM WHNFData +makeITuple [] = return (ITuple []) +makeITuple [x] = return x +makeITuple xs = ITuple <$> mapM newEvaluatedObjectRef xs 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 @@ -1,122 +1,139 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} {- | Module : Language.Egison.Desugar Licence : MIT -This module provide desugar functions. +This module provides desugar functions. -} module Language.Egison.Desugar - ( - desugarTopExpr + ( desugarTopExpr + , desugarTopExprs , desugarExpr ) where import Control.Monad.Except (throwError) import Data.Char (toUpper) -import Data.Set (Set) -import qualified Data.Set as S +import Data.Foldable (foldrM) +import Data.List (union) import Language.Egison.AST import Language.Egison.Data -import Language.Egison.IState (fresh, freshV) +import Language.Egison.IExpr +import Language.Egison.RState -desugarTopExpr :: EgisonTopExpr -> EvalM EgisonTopExpr -desugarTopExpr (Define name expr) = Define name <$> desugar expr -desugarTopExpr (DefineWithIndices (VarWithIndices name is) expr) = do - body <- desugar expr - let indexNames = map extractIndex is - let indexNamesCollection = CollectionExpr (map (ElementExpr . stringToVarExpr) indexNames) - return $ Define (Var name (map (const () <$>) is)) - (WithSymbolsExpr indexNames (TransposeExpr indexNamesCollection body)) -desugarTopExpr (Redefine name expr) = Redefine name <$> desugar expr -desugarTopExpr (Test expr) = Test <$> desugar expr -desugarTopExpr (Execute expr) = Execute <$> desugar expr -desugarTopExpr expr = return expr -desugarExpr :: EgisonExpr -> EvalM EgisonExpr +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 +desugarTopExpr (Test expr) = Just . ITest <$> desugar expr +desugarTopExpr (Execute expr) = Just . IExecute <$> desugar expr +desugarTopExpr (Load file) = return . Just $ ILoad file +desugarTopExpr (LoadFile file) = return . Just $ ILoadFile file +desugarTopExpr _ = return Nothing + +desugarTopExprs :: [TopExpr] -> EvalM [ITopExpr] +desugarTopExprs [] = return [] +desugarTopExprs (expr : exprs) = do + expr' <- desugarTopExpr expr + case expr' of + Nothing -> desugarTopExprs exprs + Just expr' -> (expr' :) <$> desugarTopExprs exprs + +desugarExpr :: Expr -> EvalM IExpr desugarExpr = desugar -desugar :: EgisonExpr -> EvalM EgisonExpr +desugar :: Expr -> EvalM IExpr +desugar (ConstantExpr c) = return $ IConstantExpr c +desugar (VarExpr var) = return $ IVarExpr var + desugar (AlgebraicDataMatcherExpr patterns) = do - matcherName <- freshV - let matcherRef = VarExpr matcherName + matcherName <- fresh + let matcherRef = IVarExpr matcherName matcher <- genMatcherClauses patterns matcherRef - return $ LetRecExpr [([matcherName], matcher)] matcherRef + return $ ILetRecExpr [(PDPatVar (stringToVar matcherName), matcher)] matcherRef where - genMatcherClauses :: [(String, [EgisonExpr])] -> EgisonExpr -> EvalM EgisonExpr + genMatcherClauses :: [(String, [Expr])] -> IExpr -> EvalM IExpr genMatcherClauses patterns matcher = do main <- genMainClause patterns matcher body <- mapM genMatcherClause patterns footer <- genSomethingClause let clauses = [main] ++ body ++ [footer] - return $ MatcherExpr clauses + return $ IMatcherExpr clauses - genMainClause :: [(String, [EgisonExpr])] -> EgisonExpr -> EvalM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) + genMainClause :: [(String, [Expr])] -> IExpr -> EvalM (PrimitivePatPattern, IExpr, [(IPrimitiveDataPattern, IExpr)]) genMainClause patterns matcher = do clauses <- genClauses patterns - return (PPValuePat "val", TupleExpr [] - ,[(PDPatVar "tgt", MatchExpr BFSMode - (TupleExpr [stringToVarExpr "val", stringToVarExpr "tgt"]) - (TupleExpr [matcher, matcher]) - clauses)]) + return (PPValuePat "val", ITupleExpr [], + [(PDPatVar (stringToVar "tgt"), + IMatchExpr BFSMode + (ITupleExpr [IVarExpr "val", IVarExpr "tgt"]) + (ITupleExpr [matcher, matcher]) + clauses)]) where - genClauses :: [(String, [EgisonExpr])] -> EvalM [MatchClause] + genClauses :: [(String, [Expr])] -> EvalM [IMatchClause] genClauses patterns = (++) <$> mapM genClause patterns - <*> pure [(TuplePat [WildCard, WildCard], matchingFailure)] + <*> pure [(ITuplePat [IWildCard, IWildCard], matchingFailure)] - genClause :: (String, [EgisonExpr]) -> EvalM MatchClause + genClause :: (String, [Expr]) -> EvalM IMatchClause genClause pattern = do (pat0, pat1) <- genMatchingPattern pattern - return (TuplePat [pat0, pat1], matchingSuccess) + return (ITuplePat [pat0, pat1], matchingSuccess) - genMatchingPattern :: (String, [EgisonExpr]) -> EvalM (EgisonPattern, EgisonPattern) + genMatchingPattern :: (String, [Expr]) -> EvalM (IPattern, IPattern) genMatchingPattern (name, patterns) = do - names <- mapM (const freshV) patterns - return (InductivePat name (map PatVar names), - InductivePat name (map (ValuePat . VarExpr) names)) + names <- mapM (const fresh) patterns + return (IInductivePat name (map IPatVar names), + IInductivePat name (map (IValuePat . IVarExpr) names)) - genMatcherClause :: (String, [EgisonExpr]) -> EvalM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) + genMatcherClause :: (String, [Expr]) -> EvalM (PrimitivePatPattern, IExpr, [(IPrimitiveDataPattern, IExpr)]) genMatcherClause pattern = do (ppat, matchers) <- genPrimitivePatPat pattern (dpat, body) <- genPrimitiveDataPat pattern - return (ppat, TupleExpr matchers, [(dpat, CollectionExpr [ElementExpr . TupleExpr $ body]), (PDWildCard, matchingFailure)]) + return (ppat, ITupleExpr matchers, [(dpat, ICollectionExpr [ITupleExpr body]), (PDWildCard, matchingFailure)]) where - genPrimitivePatPat :: (String, [EgisonExpr]) -> EvalM (PrimitivePatPattern, [EgisonExpr]) + genPrimitivePatPat :: (String, [Expr]) -> EvalM (PrimitivePatPattern, [IExpr]) genPrimitivePatPat (name, matchers) = do patterns' <- mapM (const $ return PPPatVar) matchers - return (PPInductivePat name patterns', matchers) + matchers' <- mapM desugar matchers + return (PPInductivePat name patterns', matchers') - genPrimitiveDataPat :: (String, [EgisonExpr]) -> EvalM (PrimitiveDataPattern, [EgisonExpr]) + genPrimitiveDataPat :: (String, [Expr]) -> EvalM (IPrimitiveDataPattern, [IExpr]) genPrimitiveDataPat (name, patterns) = do - patterns' <- mapM (const freshV) patterns - return (PDInductivePat (capitalize name) $ map (PDPatVar . show) patterns', map VarExpr patterns') + patterns' <- mapM (const fresh) patterns + return (PDInductivePat (capitalize name) $ map (PDPatVar . stringToVar) patterns', map IVarExpr patterns') capitalize :: String -> String capitalize (x:xs) = toUpper x : xs - genSomethingClause :: EvalM (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) + genSomethingClause :: EvalM (PrimitivePatPattern, IExpr, [(IPrimitiveDataPattern, IExpr)]) genSomethingClause = - return (PPPatVar, TupleExpr [SomethingExpr], [(PDPatVar "tgt", CollectionExpr [ElementExpr (stringToVarExpr "tgt")])]) + return (PPPatVar, ITupleExpr [IConstantExpr SomethingExpr], [(PDPatVar (stringToVar "tgt"), ICollectionExpr [IVarExpr "tgt"])]) - matchingSuccess :: EgisonExpr - matchingSuccess = CollectionExpr [ElementExpr $ TupleExpr []] + matchingSuccess :: IExpr + matchingSuccess = ICollectionExpr [ITupleExpr []] - matchingFailure :: EgisonExpr - matchingFailure = CollectionExpr [] + matchingFailure :: IExpr + matchingFailure = ICollectionExpr [] desugar (MatchAllLambdaExpr matcher clauses) = do name <- fresh - desugar $ LambdaExpr [TensorArg name] (MatchAllExpr BFSMode (stringToVarExpr name) matcher clauses) + ILambdaExpr Nothing [name] <$> + desugar (MatchAllExpr BFSMode (VarExpr name) matcher clauses) desugar (MatchLambdaExpr matcher clauses) = do name <- fresh - desugar $ LambdaExpr [TensorArg name] (MatchExpr BFSMode (stringToVarExpr name) matcher clauses) + ILambdaExpr Nothing [name] <$> + desugar (MatchExpr BFSMode (VarExpr name) matcher clauses) -- TODO: Allow nested MultiSubscript and MultiSuperscript desugar (IndexedExpr b expr indices) = @@ -124,347 +141,425 @@ [MultiSubscript x y] -> case (x, y) of (IndexedExpr b1 e1 [n1], IndexedExpr _ _ [n2]) -> - desugarMultiScript SubrefsExpr b1 e1 n1 n2 - (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr _ _ [n2]]) -> - desugarMultiScript SubrefsExpr b1 e1 n1 n2 + 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 SuprefsExpr b1 e1 n1 n2 - (TupleExpr [IndexedExpr b1 e1 [n1]], TupleExpr [IndexedExpr _ _ [n2]]) -> - desugarMultiScript SuprefsExpr b1 e1 n1 n2 + desugarMultiScript ISuprefsExpr b1 e1 n1 n2 _ -> throwError $ Default "Index should be IndexedExpr for multi superscript" - _ -> IndexedExpr b <$> desugar expr <*> mapM desugarIndex indices + _ -> IIndexedExpr b <$> desugar expr <*> mapM desugarIndex indices where desugarMultiScript refExpr b1 e1 n1 n2 = do - k <- fresh - return $ refExpr b expr (makeApply "map" - [LambdaExpr [TensorArg k] (IndexedExpr b1 e1 [Subscript $ stringToVarExpr k]), - makeApply "between" [extractIndex n1, extractIndex n2]]) + 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)]), + makeIApply "between" [n1', n2']]) desugar (SubrefsExpr bool expr1 expr2) = - SubrefsExpr bool <$> desugar expr1 <*> desugar expr2 + ISubrefsExpr bool <$> desugar expr1 <*> desugar expr2 desugar (SuprefsExpr bool expr1 expr2) = - SuprefsExpr bool <$> desugar expr1 <*> desugar expr2 + ISuprefsExpr bool <$> desugar expr1 <*> desugar expr2 desugar (UserrefsExpr bool expr1 expr2) = - UserrefsExpr bool <$> desugar expr1 <*> desugar expr2 - -desugar (PowerExpr expr1 expr2) = - (\x y -> makeApply "**" [x, y]) <$> desugar expr1 <*> desugar expr2 - -desugar (InductiveDataExpr name exprs) = - InductiveDataExpr name <$> mapM desugar exprs - -desugar (TupleExpr exprs) = - TupleExpr <$> mapM desugar exprs - -desugar expr@(CollectionExpr []) = return expr - -desugar (CollectionExpr (ElementExpr elm:inners)) = do - elm' <- desugar elm - CollectionExpr inners' <- desugar (CollectionExpr inners) - return $ CollectionExpr (ElementExpr elm':inners') + IUserrefsExpr bool <$> desugar expr1 <*> desugar expr2 -desugar (CollectionExpr (SubCollectionExpr sub:inners)) = do - sub' <- desugar sub - CollectionExpr inners' <- desugar (CollectionExpr inners) - return $ CollectionExpr (SubCollectionExpr sub':inners') +desugar (TupleExpr exprs) = ITupleExpr <$> mapM desugar exprs +desugar (CollectionExpr xs) = ICollectionExpr <$> mapM desugar xs +desugar (ConsExpr x xs) = IConsExpr <$> desugar x <*> desugar xs +desugar (JoinExpr x xs) = IJoinExpr <$> desugar x <*> desugar xs desugar (HashExpr exprPairs) = - HashExpr <$> mapM (\(expr1, expr2) -> (,) <$> desugar expr1 <*> desugar expr2) exprPairs + IHashExpr <$> mapM (\(expr1, expr2) -> (,) <$> desugar expr1 <*> desugar expr2) exprPairs desugar (VectorExpr exprs) = - VectorExpr <$> mapM desugar exprs + IVectorExpr <$> mapM desugar exprs desugar (TensorExpr nsExpr xsExpr) = - TensorExpr <$> desugar nsExpr <*> desugar xsExpr + ITensorExpr <$> desugar nsExpr <*> desugar xsExpr -desugar (LambdaExpr names expr) = do +-- Desugar of LambdaExpr takes place in 2 stages. +-- * LambdaExpr -> LambdaExpr' : Desugar pattern matches at the arg positions +-- * LambdaExpr' -> ILambdaExpr : Desugar ScalarArg and InvertedScalarArg +desugar (LambdaExpr args expr) = do + (args', expr') <- foldrM desugarArg ([], expr) args + desugar $ LambdaExpr' args' expr' + where + desugarArg :: Arg ArgPattern -> ([Arg String], Expr) -> EvalM ([Arg String], Expr) + desugarArg (TensorArg x) (args, expr) = do + (var, expr') <- desugarArgPat x expr + return (TensorArg var : args, expr') + desugarArg (ScalarArg x) (args, expr) = do + (var, expr') <- desugarArgPat x expr + return (ScalarArg var : args, expr') + desugarArg (InvertedScalarArg x) (args, expr) = do + (var, expr') <- desugarArgPat x expr + return (InvertedScalarArg var : args, expr') + + -- 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) + desugarArgPat APWildCard expr = do + tmp <- fresh + return (tmp, LetExpr [Bind PDWildCard (VarExpr tmp)] expr) + desugarArgPat (APPatVar var) expr = return (var, expr) + desugarArgPat (APTuplePat args) expr = do + tmp <- fresh + tmps <- mapM (const fresh) args + 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 + tmps <- mapM (const fresh) args + 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) + desugarArgPat (APConsPat arg1 arg2) expr = do + tmp <- fresh + tmp1 <- fresh + tmp2 <- fresh + return (tmp, LetExpr [Bind (PDConsPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)] + (ApplyExpr (LambdaExpr [arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2])) + desugarArgPat (APSnocPat arg1 arg2) expr = do + tmp <- fresh + tmp1 <- fresh + tmp2 <- fresh + return (tmp, LetExpr [Bind (PDSnocPat (PDPatVar tmp1) (PDPatVar tmp2)) (VarExpr tmp)] + (ApplyExpr (LambdaExpr [arg1, arg2] expr) [VarExpr tmp1, VarExpr tmp2])) + +desugar (LambdaExpr' names expr) = do let (args', expr') = foldr desugarInvertedArgs ([], expr) names - expr'' <- desugar expr' - return $ LambdaExpr args' expr'' + expr' <- desugar expr' + return $ ILambdaExpr Nothing args' expr' where - desugarInvertedArgs :: Arg -> ([Arg], EgisonExpr) -> ([Arg], EgisonExpr) - desugarInvertedArgs (TensorArg x) (args, expr) = (TensorArg x : args, expr) + desugarInvertedArgs :: Arg String -> ([String], Expr) -> ([String], Expr) + desugarInvertedArgs (TensorArg x) (args, expr) = (x : args, expr) desugarInvertedArgs (ScalarArg x) (args, expr) = - (TensorArg x : args, - TensorMapExpr (LambdaExpr [TensorArg x] expr) (stringToVarExpr x)) + (x : args, + TensorMapExpr (LambdaExpr' [TensorArg x] expr) (VarExpr x)) desugarInvertedArgs (InvertedScalarArg x) (args, expr) = - (TensorArg x : args, - TensorMapExpr (LambdaExpr [TensorArg x] expr) (FlipIndicesExpr (stringToVarExpr x))) + (x : args, + TensorMapExpr (LambdaExpr' [TensorArg x] expr) (FlipIndicesExpr (VarExpr x))) desugar (MemoizedLambdaExpr names expr) = - MemoizedLambdaExpr names <$> desugar expr + IMemoizedLambdaExpr names <$> desugar expr desugar (CambdaExpr name expr) = - CambdaExpr name <$> desugar expr + ICambdaExpr name <$> desugar expr desugar (PatternFunctionExpr names pattern) = - PatternFunctionExpr names <$> desugarPattern pattern + IPatternFunctionExpr names <$> desugarPattern pattern desugar (IfExpr expr0 expr1 expr2) = - IfExpr <$> desugar expr0 <*> desugar expr1 <*> desugar expr2 - -desugar (LetRecExpr binds expr) = - LetRecExpr <$> desugarBindings binds <*> desugar expr + IIfExpr <$> desugar expr0 <*> desugar expr1 <*> desugar expr2 desugar (LetExpr binds expr) = - LetExpr <$> desugarBindings binds <*> desugar expr + ILetExpr <$> desugarBindings binds <*> desugar expr -desugar (LetStarExpr binds expr) = do - binds' <- desugarBindings binds - expr' <- desugar expr - return $ foldr (\bind ret -> LetExpr [bind] ret) expr' binds' +desugar (LetRecExpr binds expr) = + ILetRecExpr <$> desugarBindings binds <*> desugar expr desugar (WithSymbolsExpr vars expr) = - WithSymbolsExpr vars <$> desugar expr + IWithSymbolsExpr vars <$> desugar expr desugar (MatchExpr pmmode expr0 expr1 clauses) = - MatchExpr pmmode <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses + IMatchExpr pmmode <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses desugar (MatchAllExpr pmmode expr0 expr1 clauses) = - MatchAllExpr pmmode <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses + IMatchAllExpr pmmode <$> desugar expr0 <*> desugar expr1 <*> desugarMatchClauses clauses desugar (DoExpr binds expr) = - DoExpr <$> desugarBindings binds <*> desugar expr - -desugar (IoExpr expr) = - IoExpr <$> desugar expr + IDoExpr <$> desugarBindings binds <*> desugar expr -desugar (PrefixExpr "-" expr) = - desugar (InfixExpr mult (IntegerExpr (-1)) expr) - where mult = findOpFrom "*" reservedExprInfix -desugar (PrefixExpr "!" (ApplyExpr expr1 expr2)) = - WedgeApplyExpr <$> desugar expr1 <*> desugar expr2 -desugar (PrefixExpr "'" expr) = QuoteExpr <$> desugar expr -desugar (PrefixExpr "`" expr) = QuoteSymbolExpr <$> desugar expr +desugar (PrefixExpr "-" expr) = do + expr' <- desugar expr + return $ makeIApply "*" [IConstantExpr (IntegerExpr (-1)), expr'] +desugar (PrefixExpr "!" (ApplyExpr expr args)) = + IWedgeApplyExpr <$> desugar expr <*> mapM desugar args +desugar (PrefixExpr "'" expr) = IQuoteExpr <$> desugar expr +desugar (PrefixExpr "`" expr) = IQuoteSymbolExpr <$> desugar expr +desugar (PrefixExpr op _) = fail ("Unknown prefix " ++ op) desugar (InfixExpr op expr1 expr2) | isWedge op = - (\x y -> WedgeApplyExpr (stringToVarExpr (func op)) (TupleExpr [x, y])) + (\x y -> IWedgeApplyExpr (IVarExpr (repr op)) [x, y]) <$> desugar expr1 <*> desugar expr2 desugar (InfixExpr op expr1 expr2) | repr op == "::" = - (\x y -> CollectionExpr [ElementExpr x, SubCollectionExpr y]) <$> desugar expr1 <*> desugar expr2 + IConsExpr <$> desugar expr1 <*> desugar expr2 desugar (InfixExpr op expr1 expr2) | repr op == "++" = - (\x y -> CollectionExpr [SubCollectionExpr x, SubCollectionExpr y]) <$> desugar expr1 <*> desugar expr2 + IJoinExpr <$> desugar expr1 <*> desugar expr2 desugar (InfixExpr op expr1 expr2) = - (\x y -> makeApply (func op) [x, y]) <$> desugar expr1 <*> desugar expr2 + (\x y -> makeIApply (repr op) [x, y]) <$> desugar expr1 <*> desugar expr2 -- section -- -- If `op` is not a cambda, simply desugar it into the function -desugar (SectionExpr op Nothing Nothing) | not (isWedge op) = - desugar (stringToVarExpr (func op)) +desugar (SectionExpr op Nothing Nothing) + | not (isWedge op || repr op `elem` ["::", "++"]) = + desugar (VarExpr (repr op)) desugar (SectionExpr op Nothing Nothing) = do x <- fresh y <- fresh - desugar $ LambdaExpr [TensorArg x, TensorArg y] - (InfixExpr op (stringToVarExpr x) (stringToVarExpr y)) + ILambdaExpr Nothing [x, y] <$> desugar (InfixExpr op (VarExpr x) (VarExpr y)) desugar (SectionExpr op Nothing (Just expr2)) = do x <- fresh - desugar $ LambdaExpr [TensorArg x] - (InfixExpr op (stringToVarExpr x) expr2) + ILambdaExpr Nothing [x] <$> desugar (InfixExpr op (VarExpr x) expr2) desugar (SectionExpr op (Just expr1) Nothing) = do y <- fresh - desugar $ LambdaExpr [TensorArg y] - (InfixExpr op expr1 (stringToVarExpr y)) + ILambdaExpr Nothing [y] <$> desugar (InfixExpr op expr1 (VarExpr y)) desugar SectionExpr{} = throwError $ Default "Cannot reach here: section with both arguments" desugar (SeqExpr expr0 expr1) = - SeqExpr <$> desugar expr0 <*> desugar expr1 + ISeqExpr <$> desugar expr0 <*> desugar expr1 desugar (GenerateTensorExpr fnExpr sizeExpr) = - GenerateTensorExpr <$> desugar fnExpr <*> desugar sizeExpr + IGenerateTensorExpr <$> desugar fnExpr <*> desugar sizeExpr desugar (TensorContractExpr tExpr) = - TensorContractExpr <$> desugar tExpr + ITensorContractExpr <$> desugar tExpr +desugar (TensorMapExpr (LambdaExpr' [x] (TensorMapExpr (LambdaExpr' [y] expr) b)) a) = + desugar (TensorMap2Expr (LambdaExpr' [x, y] expr) a b) desugar (TensorMapExpr (LambdaExpr [x] (TensorMapExpr (LambdaExpr [y] expr) b)) a) = desugar (TensorMap2Expr (LambdaExpr [x, y] expr) a b) desugar (TensorMapExpr fnExpr tExpr) = - TensorMapExpr <$> desugar fnExpr <*> desugar tExpr + ITensorMapExpr <$> desugar fnExpr <*> desugar tExpr desugar (TensorMap2Expr fnExpr t1Expr t2Expr) = - TensorMap2Expr <$> desugar fnExpr <*> desugar t1Expr <*> desugar t2Expr + ITensorMap2Expr <$> desugar fnExpr <*> desugar t1Expr <*> desugar t2Expr desugar (TransposeExpr vars expr) = - TransposeExpr <$> desugar vars <*> desugar expr + ITransposeExpr <$> desugar vars <*> desugar expr desugar (FlipIndicesExpr expr) = - FlipIndicesExpr <$> desugar expr + IFlipIndicesExpr <$> desugar expr -desugar (ApplyExpr expr0 expr1) = - ApplyExpr <$> desugar expr0 <*> desugar expr1 +desugar (ApplyExpr expr args) = + IApplyExpr <$> desugar expr <*> mapM desugar args desugar (CApplyExpr expr0 expr1) = - CApplyExpr <$> desugar expr0 <*> desugar expr1 + ICApplyExpr <$> desugar expr0 <*> desugar expr1 desugar FreshVarExpr = do id <- fresh - return $ stringToVarExpr (":::" ++ id) + return $ IVarExpr (":::" ++ id) desugar (MatcherExpr patternDefs) = - MatcherExpr <$> mapM desugarPatternDef patternDefs + IMatcherExpr <$> mapM desugarPatternDef patternDefs -desugar (AnonParamExpr n) = return $ AnonParamExpr n +desugar (AnonParamExpr n) = return $ IVarExpr ('%' : show n) desugar (AnonParamFuncExpr n expr) = do expr' <- desugar expr - return $ LetRecExpr [([stringToVar "::0"], AnonParamFuncExpr n expr')] (stringToVarExpr "::0") + let lambda = ILambdaExpr Nothing (map (\n -> '%' : show n) [1..n]) expr' + return $ ILetRecExpr [(PDPatVar (stringToVar "%0"), lambda)] (IVarExpr "%0") desugar (QuoteExpr expr) = - QuoteExpr <$> desugar expr + IQuoteExpr <$> desugar expr desugar (QuoteSymbolExpr expr) = - QuoteSymbolExpr <$> desugar expr + IQuoteSymbolExpr <$> desugar expr -desugar (WedgeApplyExpr expr0 expr1) = - WedgeApplyExpr <$> desugar expr0 <*> desugar expr1 +desugar (WedgeApplyExpr expr args) = + IWedgeApplyExpr <$> desugar expr <*> mapM desugar args -desugar expr = return expr +desugar (FunctionExpr args) = return $ IFunctionExpr args -desugarIndex :: Index EgisonExpr -> EvalM (Index EgisonExpr) -desugarIndex index = traverse desugar index +desugarIndex :: IndexExpr Expr -> EvalM (Index IExpr) +desugarIndex (Subscript e) = Sub <$> desugar e +desugarIndex (Superscript e) = Sup <$> desugar e +desugarIndex (SupSubscript e) = SupSub <$> desugar e +desugarIndex (Userscript e) = User <$> desugar e +desugarIndex _ = undefined -desugarPattern :: EgisonPattern -> EvalM EgisonPattern -desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' (desugarPatternInfix pattern) +desugarPattern :: Pattern -> EvalM IPattern +desugarPattern pat = + case collectName pat of + [] -> desugarPattern' pat + names -> ILetPat (map makeBinding names) <$> desugarPattern' pat where - collectNames :: [EgisonPattern] -> Set String - collectNames patterns = S.unions $ map collectName patterns - - collectName :: EgisonPattern -> Set String - collectName (ForallPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 - collectName (InfixPat _ pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 - collectName (NotPat pattern) = collectName pattern - collectName (AndPat patterns) = collectNames patterns - collectName (OrPat patterns) = collectNames patterns - collectName (TuplePat patterns) = collectNames patterns - collectName (InductiveOrPApplyPat _ patterns) = collectNames patterns - collectName (InductivePat _ patterns) = collectNames patterns - collectName (PApplyPat _ patterns) = collectNames patterns - collectName (DApplyPat _ patterns) = collectNames patterns - collectName (LoopPat _ (LoopRange _ _ endNumPat) pattern1 pattern2) = collectName endNumPat `S.union` collectName pattern1 `S.union` collectName pattern2 - collectName (LetPat _ pattern) = collectName pattern - collectName (IndexedPat (PatVar name) _) = S.singleton $ show name - collectName (DivPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 - collectName (PlusPat patterns) = collectNames patterns - collectName (MultPat patterns) = collectNames patterns - collectName (PowerPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2 - collectName _ = S.empty + collectNames :: [Pattern] -> [String] + collectNames pats = foldl union [] (map collectName pats) - makeBinding :: String -> BindingExpr - makeBinding name = ([stringToVar name], HashExpr []) + 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 (LoopPat _ (LoopRange _ _ endNumPat) pat1 pat2) = collectName endNumPat `union` collectName pat1 `union` collectName pat2 + collectName (LetPat _ pat) = collectName pat + collectName (IndexedPat (PatVar var) _) = [var] + collectName _ = [] -desugarPatternInfix :: EgisonPattern -> EgisonPattern -desugarPatternInfix (IndexedPat pat es) = IndexedPat (desugarPatternInfix pat) es -desugarPatternInfix (LetPat bindings pat) = LetPat bindings (desugarPatternInfix pat) -desugarPatternInfix (InfixPat Infix{ repr = "&" } pat1 pat2) = - AndPat [desugarPatternInfix pat1, desugarPatternInfix pat2] -desugarPatternInfix (InfixPat Infix{ repr = "|" } pat1 pat2) = - OrPat [desugarPatternInfix pat1, desugarPatternInfix pat2] -desugarPatternInfix (InfixPat Infix{ repr = "^" } pat1 pat2) = - PowerPat (desugarPatternInfix pat1) (desugarPatternInfix pat2) -desugarPatternInfix (InfixPat Infix{ repr = "*" } pat1 pat2) = - MultPat [desugarPatternInfix pat1, desugarPatternInfix pat2] -desugarPatternInfix (InfixPat Infix{ repr = "+" } pat1 pat2) = - PlusPat [desugarPatternInfix pat1, desugarPatternInfix pat2] -desugarPatternInfix (InfixPat Infix{ func = f } pat1 pat2) = - InductivePat f [desugarPatternInfix pat1, desugarPatternInfix pat2] -desugarPatternInfix (NotPat pat) = NotPat (desugarPatternInfix pat) -desugarPatternInfix (ForallPat pat1 pat2) = - ForallPat (desugarPatternInfix pat1) (desugarPatternInfix pat2) -desugarPatternInfix (TuplePat pats) = TuplePat (map desugarPatternInfix pats) -desugarPatternInfix (InductivePat ctor pats) = - InductivePat ctor (map desugarPatternInfix pats) -desugarPatternInfix (LoopPat name range pat1 pat2) = - LoopPat name range (desugarPatternInfix pat1) (desugarPatternInfix pat2) -desugarPatternInfix (PApplyPat expr pats) = - PApplyPat expr (map desugarPatternInfix pats) -desugarPatternInfix (InductiveOrPApplyPat name pats) = - InductiveOrPApplyPat name (map desugarPatternInfix pats) -desugarPatternInfix (SeqConsPat pat1 pat2) = - SeqConsPat (desugarPatternInfix pat1) (desugarPatternInfix pat2) -desugarPatternInfix (DApplyPat pat pats) = - DApplyPat (desugarPatternInfix pat) (map desugarPatternInfix pats) -desugarPatternInfix (DivPat pat1 pat2) = - DivPat (desugarPatternInfix pat1) (desugarPatternInfix pat2) -desugarPatternInfix (PlusPat pats) = PlusPat (map desugarPatternInfix pats) -desugarPatternInfix (MultPat pats) = MultPat (map desugarPatternInfix pats) -desugarPatternInfix (PowerPat pat1 pat2) = - PowerPat (desugarPatternInfix pat1) (desugarPatternInfix pat2) -desugarPatternInfix pat = pat + makeBinding :: String -> IBindingExpr + makeBinding var = (PDPatVar (stringToVar var), IHashExpr []) -desugarPattern' :: EgisonPattern -> EvalM EgisonPattern -desugarPattern' (ValuePat expr) = ValuePat <$> desugar expr -desugarPattern' (PredPat expr) = PredPat <$> desugar expr -desugarPattern' (NotPat pattern) = NotPat <$> desugarPattern' pattern -desugarPattern' (ForallPat pattern1 pattern2) = ForallPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 -desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns -desugarPattern' (OrPat patterns) = OrPat <$> mapM desugarPattern' patterns -desugarPattern' (TuplePat patterns) = TuplePat <$> mapM desugarPattern' patterns -desugarPattern' (InductiveOrPApplyPat name patterns) = InductiveOrPApplyPat name <$> mapM desugarPattern' patterns -desugarPattern' (InductivePat name patterns) = InductivePat name <$> mapM desugarPattern' patterns -desugarPattern' (IndexedPat pattern exprs) = IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs -desugarPattern' (PApplyPat expr patterns) = PApplyPat <$> desugar expr <*> mapM desugarPattern' patterns -desugarPattern' (DApplyPat pattern patterns) = DApplyPat <$> desugarPattern' pattern <*> mapM desugarPattern' patterns -desugarPattern' (LoopPat name range pattern1 pattern2) = LoopPat name <$> desugarLoopRange range <*> desugarPattern' pattern1 <*> desugarPattern' pattern2 -desugarPattern' (LetPat binds pattern) = LetPat <$> desugarBindings binds <*> desugarPattern' pattern -desugarPattern' (SeqConsPat pattern1 pattern2) = SeqConsPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 -desugarPattern' (DivPat pattern1 pattern2) = do - pat1' <- desugarPattern' pattern1 - pat2' <- desugarPattern' pattern2 - return $ InductivePat "div" [pat1', pat2'] -desugarPattern' (PlusPat patterns) = do - pats' <- mapM desugarPattern' (concatMap flatten patterns) - case reverse pats' of - [] -> return $ InductivePat "plus" [ValuePat (IntegerExpr 0)] - lp:hps -> - return $ InductivePat "plus" [foldr (\p acc -> InductivePat "cons" [p, acc]) lp (reverse hps)] - where - flatten (PlusPat xs) = concatMap flatten xs - flatten pat = [pat] -desugarPattern' (MultPat patterns) = do - intPat:pats' <- mapM desugarPattern' (concatMap flatten patterns) - case reverse pats' of - [] -> return $ InductivePat "mult" [intPat, ValuePat (IntegerExpr 1)] - lp:hps -> do - let mono = foldr (\p acc -> case p of - PowerPat p1 p2 -> InductivePat "ncons" [p1, p2, acc] - _ -> InductivePat "cons" [p, acc]) - (case lp of - PowerPat p1 p2 -> InductivePat "ncons" [p1, p2, ValuePat (IntegerExpr 1)] - _ -> lp) - (reverse hps) - return $ InductivePat "mult" [intPat, mono] - where - flatten (MultPat xs) = concatMap flatten xs - flatten pat = [pat] -desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 -desugarPattern' pattern = return pattern +desugarPattern' :: Pattern -> EvalM IPattern +desugarPattern' WildCard = return IWildCard +desugarPattern' ContPat = return IContPat +desugarPattern' SeqNilPat = return ISeqNilPat +desugarPattern' LaterPatVar = return ILaterPatVar +desugarPattern' (VarPat v) = return (IVarPat v) +desugarPattern' (PatVar var) = return (IPatVar var) +desugarPattern' (ValuePat expr) = IValuePat <$> desugar expr +desugarPattern' (PredPat expr) = IPredPat <$> desugar expr +desugarPattern' (NotPat pat) = INotPat <$> desugarPattern' pat +desugarPattern' (AndPat pat1 pat2) = IAndPat <$> desugarPattern' pat1 <*> desugarPattern' pat2 +desugarPattern' (OrPat pat1 pat2) = IOrPat <$> desugarPattern' pat1 <*> desugarPattern' pat2 +desugarPattern' (ForallPat pat1 pat2) = IForallPat <$> desugarPattern' pat1 <*> desugarPattern' pat2 +desugarPattern' (InfixPat Op{ repr = "&" } pat1 pat2) = + IAndPat <$> desugarPattern' pat1 <*> desugarPattern' pat2 +desugarPattern' (InfixPat Op{ repr = "|" } pat1 pat2) = + IOrPat <$> desugarPattern' pat1 <*> desugarPattern' pat2 +desugarPattern' (InfixPat Op{ repr = f } pat1 pat2) = + (\x y -> IInductivePat f [x, y]) <$> desugarPattern' pat1 <*> desugarPattern' pat2 +desugarPattern' (TuplePat pats) = ITuplePat <$> mapM desugarPattern' pats +desugarPattern' (InductiveOrPApplyPat name pats) = IInductiveOrPApplyPat name <$> mapM desugarPattern' pats +desugarPattern' (InductivePat name pats) = IInductivePat name <$> mapM desugarPattern' pats +desugarPattern' (IndexedPat pat exprs) = IIndexedPat <$> desugarPattern' pat <*> mapM desugar exprs +desugarPattern' (PApplyPat expr pats) = IPApplyPat <$> desugar expr <*> mapM desugarPattern' pats +desugarPattern' (DApplyPat pat pats) = IDApplyPat <$> desugarPattern' pat <*> mapM desugarPattern' pats +desugarPattern' (LoopPat name range pat1 pat2) = ILoopPat name <$> desugarLoopRange range <*> desugarPattern' pat1 <*> desugarPattern' pat2 +desugarPattern' (LetPat binds pat) = ILetPat <$> desugarBindings binds <*> desugarPattern' pat +desugarPattern' (SeqConsPat pat1 pat2) = ISeqConsPat <$> desugarPattern' pat1 <*> desugarPattern' pat2 -desugarLoopRange :: LoopRange -> EvalM LoopRange -desugarLoopRange (LoopRange sExpr eExpr pattern) = - LoopRange <$> desugar sExpr <*> desugar eExpr <*> desugarPattern' pattern +desugarLoopRange :: LoopRange -> EvalM ILoopRange +desugarLoopRange (LoopRange sExpr eExpr pat) = + ILoopRange <$> desugar sExpr <*> desugar eExpr <*> desugarPattern' pat -desugarBindings :: [BindingExpr] -> EvalM [BindingExpr] -desugarBindings = mapM (\(name, expr) -> (name,) <$> desugar expr) +desugarBindings :: [BindingExpr] -> EvalM [IBindingExpr] +desugarBindings = mapM desugarBinding + where + desugarBinding (Bind name expr) = do + let name' = fmap stringToVar name + expr' <- desugar expr + case (name, expr') of + (PDPatVar var, ILambdaExpr Nothing args body) -> + return (name', ILambdaExpr (Just var) args body) + _ -> return (name', expr') + desugarBinding (BindWithIndices vwi expr) = do + (var, iexpr) <- desugarDefineWithIndices vwi expr + return (PDPatVar var, iexpr) -desugarMatchClauses :: [MatchClause] -> EvalM [MatchClause] -desugarMatchClauses = mapM (\(pattern, expr) -> (,) <$> desugarPattern pattern <*> desugar expr) +desugarMatchClauses :: [MatchClause] -> EvalM [IMatchClause] +desugarMatchClauses = mapM (\(pat, expr) -> (,) <$> desugarPattern pat <*> desugar expr) -desugarPatternDef :: PatternDef -> EvalM PatternDef +desugarPatternDef :: PatternDef -> EvalM IPatternDef desugarPatternDef (pp, matcher, pds) = (pp,,) <$> desugar matcher <*> desugarPrimitiveDataMatchClauses pds -desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> EvalM [(PrimitiveDataPattern, EgisonExpr)] -desugarPrimitiveDataMatchClauses = mapM (\(pd, expr) -> (pd,) <$> desugar expr) +desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, Expr)] -> EvalM [(IPrimitiveDataPattern, IExpr)] +desugarPrimitiveDataMatchClauses = mapM (\(pd, expr) -> (fmap stringToVar pd,) <$> desugar expr) -makeApply :: String -> [EgisonExpr] -> EgisonExpr -makeApply func args = ApplyExpr (stringToVarExpr func) (TupleExpr args) +desugarDefineWithIndices :: VarWithIndices -> Expr -> EvalM (Var, IExpr) +desugarDefineWithIndices (VarWithIndices name is) expr = do + let (isSubs, indexNames) = unzip $ concatMap extractSubSupIndex is + expr <- if any isExtendedIndice is + then desugarExtendedIndices is isSubs indexNames expr + else return expr + body <- desugar expr + let indexNamesCollection = ICollectionExpr (map IVarExpr indexNames) + let is' = map (\b -> if b then Sub () else Sup ()) isSubs + return (Var name is', IWithSymbolsExpr indexNames (ITransposeExpr indexNamesCollection body)) + +extractSubSupIndex :: VarIndex -> [(Bool, String)] +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 + +desugarExtendedIndices :: [VarIndex] -> [Bool] -> [String] -> Expr -> EvalM Expr +desugarExtendedIndices indices isSubs indexNames tensorBody = do + tensorName <- fresh + tensorGenExpr <- f indices (VarExpr tensorName) [] [] + let indexFunctionExpr = LambdaExpr' (map TensorArg 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) + where + f :: [VarIndex] -> Expr -> [String] -> [BindingExpr] -> EvalM Expr + f [] expr [] [] = return expr + f [] expr [] bindings = return $ LetRecExpr bindings expr + f [] expr signs bindings = + return $ LetRecExpr bindings (makeApply "product" [CollectionExpr (map VarExpr signs ++ [expr])]) + f (index:indices) expr signs bindings = do + (indices', signs', bindings') <- genBindings index + let isSubs = subOrSupScripts index + 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']) + + subOrSupScripts :: VarIndex -> [Bool] + subOrSupScripts VSubscript{} = [True] + subOrSupScripts VSuperscript{} = [False] + subOrSupScripts (VGroupScripts xs) = concatMap subOrSupScripts xs + subOrSupScripts (VSymmScripts xs) = concatMap subOrSupScripts xs + subOrSupScripts (VAntiSymmScripts xs) = concatMap subOrSupScripts xs + + genBindings :: VarIndex -> EvalM (Expr, [String], [BindingExpr]) + genBindings (VSubscript x) = return (CollectionExpr [VarExpr x], [], []) + genBindings (VSuperscript x) = return (CollectionExpr [VarExpr x], [], []) + genBindings (VGroupScripts xs) = do + (indices, signss, bindingss) <- unzip3 <$> mapM genBindings xs + let newIndices = + -- If indices are all CollectionExpr, we can calculate the concatenated result of them + case allCollections indices of + Just xs -> CollectionExpr xs + Nothing -> makeApply "concat" [CollectionExpr indices] + return (newIndices, concat signss, concat bindingss) + where + allCollections [] = Just [] + allCollections (CollectionExpr xs : exprs) = (xs ++) <$> allCollections exprs + allCollections _ = Nothing + genBindings (VSymmScripts xs) = do + (indices, signss, bindingss) <- unzip3 <$> mapM genBindings xs + let signs = concat signss + let bindings = concat bindingss + sortedCollectionName <- fresh + let newBindings = bindings ++ [Bind (PDTuplePat [PDWildCard, PDPatVar sortedCollectionName]) (makeApply "sortWithSign" [CollectionExpr indices])] + return (VarExpr sortedCollectionName, signs, newBindings) + genBindings (VAntiSymmScripts xs) = do + (indices, signss, bindingss) <- unzip3 <$> mapM genBindings xs + let signs = concat signss + let bindings = concat bindingss + sortedCollectionName <- fresh + signName <- fresh + let newBindings = bindings ++ [Bind (PDTuplePat [PDPatVar signName, PDPatVar sortedCollectionName]) (makeApply "sortWithSign" [CollectionExpr indices])] + return (VarExpr sortedCollectionName, signName : signs, newBindings) + +-- +-- Utils +-- + +extractIndexExpr :: IndexExpr a -> a +extractIndexExpr (Subscript x) = x +extractIndexExpr (Superscript x) = x +extractIndexExpr (SupSubscript x) = x +extractIndexExpr (Userscript x) = x +extractIndexExpr _ = error "extractIndexExpr: Not supported" + +isExtendedIndice :: VarIndex -> Bool +isExtendedIndice VSubscript{} = False +isExtendedIndice VSuperscript{} = False +isExtendedIndice (VGroupScripts xs) = isExtendedIndice (head xs) +isExtendedIndice _ = True diff --git a/hs-src/Language/Egison/Eval.hs b/hs-src/Language/Egison/Eval.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Eval.hs @@ -0,0 +1,169 @@ +{- | +Module : Language.Egison.Eval +Licence : MIT + +This module provides interface for evaluating Egison expressions. +-} + +module Language.Egison.Eval + -- * Eval Egison expressions + ( evalExpr + , evalTopExpr + , evalTopExprStr + , evalTopExprs + , evalTopExprsNoPrint + , runExpr + , runTopExpr + , runTopExprs + -- * Load Egison files + , loadEgisonLibrary + , loadEgisonFile + ) where + +import Control.Monad.Except (throwError) +import Control.Monad.Reader (ask, asks) +import Control.Monad.State + +import Language.Egison.AST +import Language.Egison.CmdOptions +import Language.Egison.Core +import Language.Egison.Data +import Language.Egison.Desugar +import Language.Egison.EvalState (MonadEval(..)) +import Language.Egison.IExpr +import Language.Egison.MathOutput (prettyMath) +import Language.Egison.Parser + + +-- | Evaluate an Egison expression. +evalExpr :: Env -> Expr -> EvalM EgisonValue +evalExpr env expr = desugarExpr expr >>= evalExprDeep env + +-- | Evaluate an Egison top expression. +evalTopExpr :: Env -> TopExpr -> EvalM (Maybe EgisonValue, Env) +evalTopExpr env topExpr = do + topExpr <- desugarTopExpr topExpr + case topExpr of + Nothing -> return (Nothing, env) + Just topExpr -> evalTopExpr' env topExpr + +-- | Evaluate an Egison top expression. +evalTopExprStr :: Env -> TopExpr -> EvalM (Maybe String, Env) +evalTopExprStr env topExpr = do + (val, env') <- evalTopExpr env topExpr + case val of + Nothing -> return (Nothing, env') + Just val -> do str <- valueToStr val + return (Just str, env') + +valueToStr :: EgisonValue -> EvalM String +valueToStr val = do + mathExpr <- asks optMathExpr + case mathExpr of + Nothing -> return (show val) + Just lang -> return (prettyMath lang val) + +-- | Evaluate Egison top expressions. +evalTopExprs :: Env -> [TopExpr] -> EvalM Env +evalTopExprs env exprs = do + exprs <- desugarTopExprs exprs + opts <- ask + (bindings, rest) <- collectDefs opts exprs + env <- recursiveBind env bindings + forM_ rest $ \expr -> do + (val, _) <- evalTopExpr' env expr + case val of + Nothing -> return () + Just val -> valueToStr val >>= liftIO . putStrLn + return env + +-- | Evaluate Egison top expressions. +evalTopExprsNoPrint :: Env -> [TopExpr] -> EvalM Env +evalTopExprsNoPrint env exprs = do + exprs <- desugarTopExprs exprs + opts <- ask + (bindings, rest) <- collectDefs opts exprs + env <- recursiveBind env bindings + forM_ rest $ evalTopExpr' env + return env + +-- | Evaluate an Egison expression. Input is a Haskell string. +runExpr :: Env -> String -> EvalM EgisonValue +runExpr env input = + readExpr input >>= evalExpr env + +-- | Evaluate an Egison top expression. Input is a Haskell string. +runTopExpr :: Env -> String -> EvalM (Maybe EgisonValue, Env) +runTopExpr env input = + readTopExpr input >>= evalTopExpr env + +-- | Evaluate Egison top expressions. Input is a Haskell string. +runTopExprs :: Env -> String -> EvalM Env +runTopExprs env input = + readTopExprs input >>= evalTopExprs env + +-- | Load an Egison file. +loadEgisonFile :: Env -> FilePath -> EvalM Env +loadEgisonFile env path = do + (_, env') <- evalTopExpr env (LoadFile path) + return env' + +-- | Load an Egison library. +loadEgisonLibrary :: Env -> FilePath -> EvalM Env +loadEgisonLibrary env path = do + (_, env') <- evalTopExpr env (Load path) + return env' + + +-- +-- Helper functions +-- + +collectDefs :: EgisonOpts -> [ITopExpr] -> EvalM ([(Var, IExpr)], [ITopExpr]) +collectDefs opts exprs = collectDefs' opts exprs [] [] + where + collectDefs' :: EgisonOpts -> [ITopExpr] -> [(Var, IExpr)] -> [ITopExpr] -> EvalM ([(Var, IExpr)], [ITopExpr]) + collectDefs' opts (expr:exprs) bindings rest = + case expr of + IDefine name expr -> collectDefs' opts exprs ((name, expr) : bindings) rest + ITest{} -> collectDefs' opts exprs bindings (expr : rest) + IExecute{} -> collectDefs' opts exprs bindings (expr : rest) + ILoadFile _ | optNoIO opts -> throwError (Default "No IO support") + ILoadFile file -> do + exprs' <- loadFile file >>= desugarTopExprs + collectDefs' opts (exprs' ++ exprs) bindings rest + ILoad _ | optNoIO opts -> throwError (Default "No IO support") + ILoad file -> do + exprs' <- loadLibraryFile file >>= desugarTopExprs + collectDefs' opts (exprs' ++ exprs) bindings rest + collectDefs' _ [] bindings rest = return (bindings, reverse rest) + +evalTopExpr' :: Env -> ITopExpr -> EvalM (Maybe EgisonValue, Env) +evalTopExpr' env (IDefine name expr) = do + env' <- recursiveBind env [(name, expr)] + return (Nothing, env') +evalTopExpr' env (ITest expr) = do + pushFuncName "" + val <- evalExprDeep env expr + popFuncName + return (Just val, env) +evalTopExpr' env (IExecute expr) = do + pushFuncName "" + io <- evalExprShallow env expr + case io of + Value (IOFunc m) -> m >> popFuncName >> return (Nothing, env) + _ -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack +evalTopExpr' env (ILoad file) = do + opts <- ask + when (optNoIO opts) $ throwError (Default "No IO support") + exprs <- loadLibraryFile file >>= desugarTopExprs + (bindings, _) <- collectDefs opts exprs + env' <- recursiveBind env bindings + return (Nothing, env') +evalTopExpr' env (ILoadFile file) = do + opts <- ask + when (optNoIO opts) $ throwError (Default "No IO support") + exprs <- loadFile file >>= desugarTopExprs + (bindings, _) <- collectDefs opts exprs + env' <- recursiveBind env bindings + return (Nothing, env') diff --git a/hs-src/Language/Egison/EvalState.hs b/hs-src/Language/Egison/EvalState.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/EvalState.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} + +{- | +Module : Language.Egison.EvalState +Licence : MIT + +This module defines the state during the evaluation. +-} + +module Language.Egison.EvalState + ( EvalState(..) + , initialEvalState + , MonadEval(..) + , mLabelFuncName + ) where + +import Control.Monad.Except +import Control.Monad.Trans.State.Strict + + +newtype EvalState = EvalState + -- Names of called functions for improved error message + { funcNameStack :: [String] + } + +initialEvalState :: EvalState +initialEvalState = EvalState { funcNameStack = [] } + +class (Applicative m, Monad m) => MonadEval m where + pushFuncName :: String -> m () + topFuncName :: m String + popFuncName :: m () + getFuncNameStack :: m [String] + +instance Monad m => MonadEval (StateT EvalState m) where + pushFuncName name = do + st <- get + put $ st { funcNameStack = name : funcNameStack st } + return () + topFuncName = head . funcNameStack <$> get + popFuncName = do + st <- get + put $ st { funcNameStack = tail $ funcNameStack st } + return () + getFuncNameStack = funcNameStack <$> get + +instance (MonadEval m) => MonadEval (ExceptT e m) where + pushFuncName name = lift $ pushFuncName name + topFuncName = lift topFuncName + popFuncName = lift popFuncName + getFuncNameStack = lift getFuncNameStack + +mLabelFuncName :: MonadEval m => Maybe String -> m a -> m a +mLabelFuncName Nothing m = m +mLabelFuncName (Just name) m = do + pushFuncName name + v <- m + popFuncName + return v diff --git a/hs-src/Language/Egison/IExpr.hs b/hs-src/Language/Egison/IExpr.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/IExpr.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} + +{- | +Module : Language.Egison.IExpr +Licence : MIT + +This module defines internal representation of Egison language. +-} + +module Language.Egison.IExpr + ( ITopExpr (..) + , IExpr (..) + , IPattern (..) + , ILoopRange (..) + , IBindingExpr + , IMatchClause + , IPatternDef + , IPrimitiveDataPattern + , Var (..) + , stringToVar + , Index (..) + , extractSupOrSubIndex + , extractIndex + , makeIApply + -- Re-export from AST + , ConstantExpr (..) + , PMMode (..) + , PrimitivePatPattern (..) + , PDPatternBase (..) + ) where + +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +import Language.Egison.AST ( ConstantExpr (..) + , PMMode (..) + , PrimitivePatPattern (..) + , PDPatternBase (..) + ) + +data ITopExpr + = IDefine Var IExpr + | ITest IExpr + | IExecute IExpr + | ILoadFile String + | ILoad String + deriving Show + +data IExpr + = IConstantExpr ConstantExpr + | IVarExpr String + | IIndexedExpr Bool IExpr [Index IExpr] + | ISubrefsExpr Bool IExpr IExpr + | ISuprefsExpr Bool IExpr IExpr + | IUserrefsExpr Bool IExpr IExpr + | IInductiveDataExpr String [IExpr] + | ITupleExpr [IExpr] + | ICollectionExpr [IExpr] + | IConsExpr IExpr IExpr + | IJoinExpr IExpr IExpr + | IHashExpr [(IExpr, IExpr)] + | IVectorExpr [IExpr] + | ILambdaExpr (Maybe String) [String] IExpr + | IMemoizedLambdaExpr [String] IExpr + | ICambdaExpr String IExpr + | IPatternFunctionExpr [String] IPattern + | IIfExpr IExpr IExpr IExpr + | ILetRecExpr [IBindingExpr] IExpr + | ILetExpr [IBindingExpr] IExpr + | IWithSymbolsExpr [String] IExpr + | IMatchExpr PMMode IExpr IExpr [IMatchClause] + | IMatchAllExpr PMMode IExpr IExpr [IMatchClause] + | IMatcherExpr [IPatternDef] + | IQuoteExpr IExpr + | IQuoteSymbolExpr IExpr + | IWedgeApplyExpr IExpr [IExpr] + | IDoExpr [IBindingExpr] IExpr + | ISeqExpr IExpr IExpr + | IApplyExpr IExpr [IExpr] + | ICApplyExpr IExpr IExpr + | IGenerateTensorExpr IExpr IExpr + | ITensorExpr IExpr IExpr + | ITensorContractExpr IExpr + | ITensorMapExpr IExpr IExpr + | ITensorMap2Expr IExpr IExpr IExpr + | ITransposeExpr IExpr IExpr + | IFlipIndicesExpr IExpr + | IFunctionExpr [String] + deriving Show + +type IBindingExpr = (IPrimitiveDataPattern, IExpr) +type IMatchClause = (IPattern, IExpr) +type IPatternDef = (PrimitivePatPattern, IExpr, [(IPrimitiveDataPattern, IExpr)]) +type IPrimitiveDataPattern = PDPatternBase Var + +data IPattern + = IWildCard + | IPatVar String + | IValuePat IExpr + | IPredPat IExpr + | IIndexedPat IPattern [IExpr] + | ILetPat [IBindingExpr] IPattern + | INotPat IPattern + | IAndPat IPattern IPattern + | IOrPat IPattern IPattern + | IForallPat IPattern IPattern + | ITuplePat [IPattern] + | IInductivePat String [IPattern] + | ILoopPat String ILoopRange IPattern IPattern + | IContPat + | IPApplyPat IExpr [IPattern] + | IVarPat String + | IInductiveOrPApplyPat String [IPattern] + | ISeqNilPat + | ISeqConsPat IPattern IPattern + | ILaterPatVar + -- For symbolic computing + | IDApplyPat IPattern [IPattern] + deriving Show + +data ILoopRange = ILoopRange IExpr IExpr IPattern + deriving Show + +data Index a + = Sub a + | Sup a + | SupSub a + | User a + | DF Integer Integer + deriving (Show, Eq, Functor, Foldable, Generic, Traversable) + +extractSupOrSubIndex :: Index a -> Maybe a +extractSupOrSubIndex (Sub x) = Just x +extractSupOrSubIndex (Sup x) = Just x +extractSupOrSubIndex (SupSub x) = Just x +extractSupOrSubIndex _ = Nothing + +extractIndex :: Index a -> a +extractIndex (Sub x) = x +extractIndex (Sup x) = x +extractIndex (SupSub x) = x +extractIndex (User x) = x +extractIndex DF{} = undefined + +data Var = Var String [Index ()] + deriving (Eq, Generic, Show) + +instance Hashable (Index ()) +instance Hashable Var + +stringToVar :: String -> Var +stringToVar name = Var name [] + +makeIApply :: String -> [IExpr] -> IExpr +makeIApply func args = IApplyExpr (IVarExpr func) args + +instance {-# OVERLAPPING #-} Show (Index String) where + show (Sup s) = "~" ++ s + show (Sub s) = "_" ++ s + show (SupSub s) = "~_" ++ s + show (User s) = "|" ++ s + show (DF _ _) = "" diff --git a/hs-src/Language/Egison/IState.hs b/hs-src/Language/Egison/IState.hs deleted file mode 100644 --- a/hs-src/Language/Egison/IState.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} - -{- | -Module : Language.Egison.IState -Licence : MIT - -This module defines the internal state of Egison runtime. --} - -module Language.Egison.IState - ( IState(..) - , MonadEval(..) - , modifyCounter - ) where - -import Control.Monad.Except -import Control.Monad.State -import Data.IORef - -import System.IO.Unsafe (unsafePerformIO) - -import Language.Egison.AST - - -data IState = IState - -- Index counter for generating fresh variable - { indexCounter :: Int - -- Names of called functions for improved error message - , funcNameStack :: [String] - } - -class (Applicative m, Monad m) => MonadEval m where - fresh :: m String - freshV :: m Var - pushFuncName :: String -> m () - topFuncName :: m String - popFuncName :: m () - getFuncNameStack :: m [String] - -instance (MonadEval m) => MonadEval (ExceptT e m) where - fresh = lift fresh - freshV = lift freshV - pushFuncName name = lift $ pushFuncName name - topFuncName = lift topFuncName - popFuncName = lift popFuncName - getFuncNameStack = lift getFuncNameStack - -{-# NOINLINE counter #-} -counter :: IORef Int -counter = unsafePerformIO $ newIORef 0 - -readCounter :: IO Int -readCounter = readIORef counter - -updateCounter :: Int -> IO () -updateCounter = writeIORef counter - -modifyCounter :: MonadIO m => StateT IState m a -> m a -modifyCounter m = do - x <- liftIO $ readCounter - (result, st) <- runStateT m (IState { indexCounter = x, funcNameStack = [] }) - liftIO $ updateCounter $ indexCounter st - return result diff --git a/hs-src/Language/Egison/Match.hs b/hs-src/Language/Egison/Match.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Match.hs @@ -0,0 +1,67 @@ +{- | +Module : Language.Egison.Match +Licence : MIT + +This module defines some data types Egison pattern matching. +-} + +module Language.Egison.Match + ( Match + , MatchingTree (..) + , MatchingState (..) + , PatternBinding + , LoopPatContext (..) + , SeqPatContext (..) + , nullMState + , MatchM + , matchFail + ) where + +import Control.Monad.Trans.Maybe + +import Language.Egison.Data +import Language.Egison.IExpr + +-- +-- Pattern Matching +-- + +type Match = [Binding] + +data MatchingState + = MState { mStateEnv :: Env + , loopPatCtx :: [LoopPatContext] + , seqPatCtx :: [SeqPatContext] + , mStateBindings :: [Binding] + , mTrees :: [MatchingTree] + } + +instance Show MatchingState where + show ms = "(MState " ++ unwords ["_", "_", "_", show (mStateBindings ms), show (mTrees ms)] ++ ")" + +data MatchingTree + = MAtom IPattern WHNFData Matcher + | MNode [PatternBinding] MatchingState + deriving Show + +type PatternBinding = (String, IPattern) + +data LoopPatContext = LoopPatContext (String, ObjectRef) ObjectRef IPattern IPattern IPattern + +data SeqPatContext + = SeqPatContext [MatchingTree] IPattern [Matcher] [WHNFData] + | ForallPatContext [Matcher] [WHNFData] + +nullMState :: MatchingState -> Bool +nullMState MState{ mTrees = [] } = True +nullMState MState{ mTrees = MNode _ state : _ } = nullMState state +nullMState _ = False + +-- +-- Monads +-- + +type MatchM = MaybeT EvalM + +matchFail :: MatchM a +matchFail = MaybeT $ return Nothing diff --git a/hs-src/Language/Egison/Math.hs b/hs-src/Language/Egison/Math.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Math.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE PatternSynonyms #-} + +{- | +Module : Language.Egison.Math +Licence : MIT + +This module provides the interface of Egison's computer algebra system. +-} + +module Language.Egison.Math + ( ScalarData (..) + , PolyExpr (..) + , TermExpr (..) + , Monomial + , SymbolExpr (..) + , Printable (..) + , pattern ZeroExpr + , pattern SingleSymbol + , pattern SingleTerm + , mathNormalize' + , rewriteSymbol + , mathPlus + , mathMult + , mathDiv + , mathNumerator + , mathDenominator + , mathNegate + ) where + +import Language.Egison.Math.Expr +import Language.Egison.Math.Arith +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 new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Math/Arith.hs @@ -0,0 +1,51 @@ +{- | +Module : Language.Egison.Math.Arith +Licence : MIT + +This module defines some basic arithmetic operations for Egison's computer +algebra system. +-} + +module Language.Egison.Math.Arith + ( mathPlus + , mathMinus + , mathMult + , mathDiv + , mathPower + , mathNumerator + , mathDenominator + ) where + +import Language.Egison.Math.Expr +import Language.Egison.Math.Normalize + +mathPlus :: ScalarData -> ScalarData -> ScalarData +mathPlus (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathPlusPoly (mathMultPoly m1 n2) (mathMultPoly m2 n1)) (mathMultPoly n1 n2) + +mathPlusPoly :: PolyExpr -> PolyExpr -> PolyExpr +mathPlusPoly (Plus ts1) (Plus ts2) = Plus (ts1 ++ ts2) + +mathMinus :: ScalarData -> ScalarData -> ScalarData +mathMinus s1 s2 = mathPlus s1 (mathNegate s2) + +mathMult :: ScalarData -> ScalarData -> ScalarData +mathMult (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathMultPoly m1 m2) (mathMultPoly n1 n2) + +mathMultPoly :: PolyExpr -> PolyExpr -> PolyExpr +mathMultPoly (Plus []) (Plus _) = Plus [] +mathMultPoly (Plus _) (Plus []) = Plus [] +mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> Plus (map (\(Term b ys) -> Term (a * b) (xs ++ ys)) ts2)) ts1) + +mathDiv :: ScalarData -> ScalarData -> ScalarData +mathDiv s (Div p1 p2) = mathMult s (Div p2 p1) + +mathPower :: ScalarData -> Integer -> ScalarData +mathPower _ 0 = SingleTerm 1 [] +mathPower s 1 = s +mathPower s n | n >= 2 = mathMult s (mathPower s (n - 1)) + +mathNumerator :: ScalarData -> ScalarData +mathNumerator (Div m _) = Div m (Plus [Term 1 []]) + +mathDenominator :: ScalarData -> ScalarData +mathDenominator (Div _ n) = Div n (Plus [Term 1 []]) diff --git a/hs-src/Language/Egison/Math/Expr.hs b/hs-src/Language/Egison/Math/Expr.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Math/Expr.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} + +{- | +Module : Language.Egison.Math.Expr +Licence : MIT + +This module defines the internal representation of mathematic objects such as +polynominals, and some useful patterns. +-} + +module Language.Egison.Math.Expr + ( ScalarData (..) + , PolyExpr (..) + , TermExpr (..) + , Monomial + , SymbolExpr (..) + , Printable (..) + , pattern ZeroExpr + , pattern SingleSymbol + , pattern SingleTerm + , ScalarM (..) + , TermM (..) + , SymbolM (..) + , term + , termM + , symbol + , symbolM + , func + , funcM + , apply + , applyM + , quote + , negQuote + , negQuoteM + , equalMonomial + , equalMonomialM + , zero + , zeroM + , singleTerm + , singleTermM + , mathScalarMult + , mathNegate + ) where + +import Prelude hiding (foldr, mappend, mconcat) +import Data.List (intercalate) + +import Control.Monad ( MonadPlus(..) ) +import Control.Egison + +import Language.Egison.IExpr (Index(..)) + +-- +-- Data +-- + + +data ScalarData + = Div PolyExpr PolyExpr + deriving Eq + +newtype PolyExpr + = Plus [TermExpr] + +data TermExpr + = Term Integer Monomial + +-- We choose the definition 'monomials' without its coefficients. +-- ex. 2 x^2 y^3 is *not* a monomial. x^2 t^3 is a monomial. +type Monomial = [(SymbolExpr, Integer)] + +data SymbolExpr + = Symbol Id String [Index ScalarData] + | Apply ScalarData [ScalarData] + | Quote ScalarData + | FunctionData ScalarData [ScalarData] [ScalarData] [Index ScalarData] -- fnname argnames args indices + deriving Eq + +type Id = String + +-- Matchers + +data ScalarM = ScalarM +instance Matcher ScalarM ScalarData + +data TermM = TermM +instance Matcher TermM TermExpr + +data SymbolM = SymbolM +instance Matcher SymbolM SymbolExpr + +term :: Pattern (PP Integer, PP Monomial) TermM TermExpr (Integer, Monomial) +term _ _ (Term a mono) = pure (a, mono) +termM :: TermM -> TermExpr -> (Eql, Multiset (Pair SymbolM Eql)) +termM TermM _ = (Eql, Multiset (Pair SymbolM Eql)) + +symbol :: Pattern (PP String) SymbolM SymbolExpr String +symbol _ _ (Symbol _ name []) = pure name +symbol _ _ _ = mzero +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 _ _ _ = mzero +funcM :: SymbolM -> SymbolExpr -> (ScalarM, List ScalarM, Multiset Eql) +funcM SymbolM _ = (ScalarM, List ScalarM, Multiset Eql) + +apply :: Pattern (PP String, PP [ScalarData]) SymbolM SymbolExpr (String, [ScalarData]) +apply _ _ (Apply (SingleSymbol (Symbol _ fn _)) args) = pure (fn, args) +apply _ _ _ = mzero +applyM :: SymbolM -> p -> (Eql, List ScalarM) +applyM SymbolM _ = (Eql, List ScalarM) + +quote :: Pattern (PP ScalarData) SymbolM SymbolExpr ScalarData +quote _ _ (Quote m) = pure m +quote _ _ _ = mzero + +negQuote :: Pattern (PP ScalarData) SymbolM SymbolExpr ScalarData +negQuote _ _ (Quote m) = pure (mathNegate m) +negQuote _ _ _ = mzero +negQuoteM :: SymbolM -> p -> ScalarM +negQuoteM SymbolM _ = ScalarM + +equalMonomial :: Pattern (PP Integer, PP Monomial) (Multiset (Pair SymbolM Eql)) Monomial (Integer, Monomial) +equalMonomial (_, VP xs) _ ys = case isEqualMonomial xs ys of + Just sgn -> pure (sgn, xs) + Nothing -> mzero +equalMonomial _ _ _ = mzero +equalMonomialM :: Multiset (Pair SymbolM Eql) -> p -> (Eql, Multiset (Pair SymbolM Eql)) +equalMonomialM (Multiset (Pair SymbolM Eql)) _ = (Eql, Multiset (Pair SymbolM Eql)) + +zero :: Pattern () ScalarM ScalarData () +zero _ _ (Div (Plus []) _) = pure () +zero _ _ _ = mzero +zeroM :: ScalarM -> p -> () +zeroM ScalarM _ = () + +singleTerm :: Pattern (PP Integer, PP Integer, PP Monomial) ScalarM ScalarData (Integer, Integer, Monomial) +singleTerm _ _ (Div (Plus [Term c mono]) (Plus [Term c2 []])) = pure (c, c2, mono) +singleTerm _ _ _ = mzero +singleTermM :: ScalarM -> p -> (Eql, Eql, Multiset (Pair SymbolM Eql)) +singleTermM ScalarM _ = (Eql, Eql, Multiset (Pair SymbolM Eql)) + + +instance ValuePattern ScalarM ScalarData where + value e () ScalarM v = if e == v then pure () else mzero + +instance ValuePattern SymbolM SymbolExpr where + value e () SymbolM v = if e == v then pure () else mzero + + +pattern ZeroExpr :: ScalarData +pattern ZeroExpr = (Div (Plus []) (Plus [Term 1 []])) + +pattern SingleSymbol :: SymbolExpr -> ScalarData +pattern SingleSymbol sym = Div (Plus [Term 1 [(sym, 1)]]) (Plus [Term 1 []]) + +-- Product of a coefficient and a monomial +pattern SingleTerm :: Integer -> Monomial -> ScalarData +pattern SingleTerm coeff mono = Div (Plus [Term coeff mono]) (Plus [Term 1 []]) + +instance Eq PolyExpr where + Plus xs == Plus ys = + match dfs ys (Multiset Eql) + [ [mc| #xs -> True |] + , [mc| _ -> False |] ] + +instance Eq TermExpr where + Term a xs == Term b ys + | a == b = isEqualMonomial xs ys == Just 1 + | a == -b = isEqualMonomial xs ys == Just (-1) + | otherwise = False + +isEqualMonomial :: Monomial -> Monomial -> Maybe Integer +isEqualMonomial xs ys = + match dfs (xs, ys) (Pair (Multiset (Pair SymbolM Eql)) (Multiset (Pair SymbolM Eql))) + [ [mc| ((quote $s, $n) : $xss, (negQuote #s, #n) : $yss) -> + case isEqualMonomial xss yss of + Nothing -> Nothing + Just sgn -> return (if even n then sgn else - sgn) |] + , [mc| (($x, $n) : $xss, (#x, #n) : $yss) -> isEqualMonomial xss yss |] + , [mc| ([], []) -> return 1 |] + , [mc| _ -> Nothing |] + ] + +-- +-- Arithmetic operations +-- + +mathScalarMult :: Integer -> ScalarData -> ScalarData +mathScalarMult c (Div m n) = Div (f c m) n + where + f c (Plus ts) = Plus (map (\(Term a xs) -> Term (c * a) xs) ts) + +mathNegate :: ScalarData -> ScalarData +mathNegate = mathScalarMult (-1) + +-- +-- Pretty printing +-- + +class Printable a where + isAtom :: a -> Bool + pretty :: a -> String + +pretty' :: Printable a => a -> String +pretty' e | isAtom e = pretty e +pretty' e = "(" ++ pretty e ++ ")" + +instance Printable ScalarData where + isAtom (Div p (Plus [Term 1 []])) = isAtom p + isAtom _ = False + + pretty (Div p1 (Plus [Term 1 []])) = pretty p1 + pretty (Div p1 p2) = pretty'' p1 ++ " / " ++ pretty' p2 + where + pretty'' :: PolyExpr -> String + pretty'' p@(Plus [_]) = pretty p + pretty'' p = "(" ++ pretty p ++ ")" + +instance Printable PolyExpr where + isAtom (Plus []) = True + isAtom (Plus [Term _ []]) = True + isAtom (Plus [Term 1 [_]]) = True + isAtom _ = False + + pretty (Plus []) = "0" + pretty (Plus (t:ts)) = pretty t ++ concatMap withSign ts + where + withSign (Term a xs) | a < 0 = " - " ++ pretty (Term (- a) xs) + withSign t = " + " ++ pretty t + +instance Printable SymbolExpr where + isAtom Symbol{} = True + isAtom (Apply _ []) = 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 + +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 (-1) xs) = "- " ++ intercalate " * " (map prettyPoweredSymbol xs) + pretty (Term a xs) = intercalate " * " (show a : map prettyPoweredSymbol xs) + +prettyPoweredSymbol :: (SymbolExpr, Integer) -> String +prettyPoweredSymbol (x, 1) = show x +prettyPoweredSymbol (x, n) = pretty' x ++ "^" ++ show n + +instance Show ScalarData where + show = pretty + +instance Show PolyExpr where + show = pretty + +instance Show TermExpr where + show = pretty + +instance Show SymbolExpr where + show = pretty + +instance {-# OVERLAPPING #-} Show (Index ScalarData) where + show (Sup i) = "~" ++ pretty' i + show (Sub i) = "_" ++ pretty' i + show (SupSub i) = "~_" ++ pretty' i + show (DF _ _) = "" + show (User i) = "|" ++ pretty' i diff --git a/hs-src/Language/Egison/Math/Normalize.hs b/hs-src/Language/Egison/Math/Normalize.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Math/Normalize.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE QuasiQuotes #-} + +{- | +Module : Language.Egison.Math.Expr +Licence : MIT + +This module implements the normalization of polynomials. Normalization rules +for particular mathematical functions (such as sqrt and sin/cos) are defined +in Rewrite.hs. +-} + +module Language.Egison.Math.Normalize + ( mathNormalize' + , termsGcd + , mathDivideTerm + ) where + +import Control.Egison + +import Language.Egison.Math.Expr + + +mathNormalize' :: ScalarData -> ScalarData +mathNormalize' = mathDivide . mathRemoveZero . mathFold . mathRemoveZeroSymbol + +termsGcd :: [TermExpr] -> TermExpr +termsGcd ts@(_:_) = + foldl1 (\(Term a xs) (Term b ys) -> Term (gcd a b) (monoGcd xs ys)) ts + where + monoGcd :: Monomial -> Monomial -> Monomial + monoGcd [] _ = [] + monoGcd ((x, n):xs) ys = + case f (x, n) ys of + (_, 0) -> monoGcd xs ys + (z, m) -> (z, m) : monoGcd xs ys + + f :: (SymbolExpr, Integer) -> Monomial -> (SymbolExpr, Integer) + f (x, _) [] = (x, 0) + f (Quote x, n) ((Quote y, m):ys) + | x == y = (Quote x, min n m) + | x == mathNegate y = (Quote x, min n m) + | otherwise = f (Quote x, n) ys + f (x, n) ((y, m):ys) + | x == y = (x, min n m) + | otherwise = f (x, n) ys + +mathDivide :: ScalarData -> ScalarData +mathDivide mExpr@(Div (Plus _) (Plus [])) = mExpr +mathDivide mExpr@(Div (Plus []) (Plus _)) = mExpr +mathDivide (Div (Plus ts1) (Plus ts2)) = + let z@(Term c zs) = termsGcd (ts1 ++ ts2) in + case ts2 of + [Term a _] | a < 0 -> Div (Plus (map (`mathDivideTerm` Term (-c) zs) ts1)) + (Plus (map (`mathDivideTerm` Term (-c) zs) ts2)) + _ -> Div (Plus (map (`mathDivideTerm` z) ts1)) + (Plus (map (`mathDivideTerm` z) ts2)) + +mathDivideTerm :: TermExpr -> TermExpr -> TermExpr +mathDivideTerm (Term a xs) (Term b ys) = + let (sgn, zs) = divMonomial xs ys in + Term (sgn * div a b) zs + where + divMonomial :: Monomial -> Monomial -> (Integer, Monomial) + divMonomial xs [] = (1, xs) + divMonomial xs ((y, m):ys) = + match dfs (y, xs) (Pair SymbolM (Multiset (Pair SymbolM Eql))) + -- Because we've applied |mathFold|, we can only divide the first matching monomial + [ [mc| (quote $s, ($x & negQuote #s, $n) : $xss) -> + let (sgn, xs') = divMonomial xss ys in + let sgn' = if even m then 1 else -1 in + if n == m then (sgn * sgn', xs') + else (sgn * sgn', (x, n - m) : xs') |] + , [mc| (_, (#y, $n) : $xss) -> + let (sgn, xs') = divMonomial xss ys in + if n == m then (sgn, xs') else (sgn, (y, n - m) : xs') |] + , [mc| _ -> divMonomial xs ys |] + ] + +mathRemoveZeroSymbol :: ScalarData -> ScalarData +mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) = + let ts1' = map (\(Term a xs) -> Term a (filter p xs)) ts1 + ts2' = map (\(Term a xs) -> Term a (filter p xs)) ts2 + in Div (Plus ts1') (Plus ts2') + where + p (_, 0) = False + p _ = True + +mathRemoveZero :: ScalarData -> ScalarData +mathRemoveZero (Div (Plus ts1) (Plus ts2)) = + let ts1' = filter (\(Term a _) -> a /= 0) ts1 in + let ts2' = filter (\(Term a _) -> a /= 0) ts2 in + case ts1' of + [] -> Div (Plus []) (Plus [Term 1 []]) + _ -> Div (Plus ts1') (Plus ts2') + +mathFold :: ScalarData -> ScalarData +mathFold = mathTermFold . mathSymbolFold + +-- x^2 y x -> x^3 y +mathSymbolFold :: ScalarData -> ScalarData +mathSymbolFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (map f ts1)) (Plus (map f ts2)) + where + f :: TermExpr -> TermExpr + f (Term a xs) = + let (sgn, ys) = g xs in Term (sgn * a) ys + g :: Monomial -> (Integer, Monomial) + g [] = (1, []) + g ((x, m):xs) = + match dfs (x, xs) (Pair SymbolM (Multiset (Pair SymbolM Eql))) + [ [mc| (quote $s, (negQuote #s, $n) : $xs) -> + let (sgn, ys) = g ((x, m + n) : xs) in + if even n then (sgn, ys) else (- sgn, ys) |] + , [mc| (_, (#x, $n) : $xs) -> g ((x, m + n) : xs) |] + , [mc| _ -> let (sgn', ys) = g xs in (sgn', (x, m):ys) |] + ] + +-- x^2 y + x^2 y -> 2 x^2 y +mathTermFold :: ScalarData -> ScalarData +mathTermFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (f ts1)) (Plus (f ts2)) + where + f :: [TermExpr] -> [TermExpr] + f [] = [] + f (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| _ -> t : f ts |] + ] diff --git a/hs-src/Language/Egison/Math/Rewrite.hs b/hs-src/Language/Egison/Math/Rewrite.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Math/Rewrite.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE QuasiQuotes #-} + +{- | +Module : Language.Egison.Math.Rewrite +Licence : MIT + +This module implements rewrite rules for common mathematical functions. +-} + +module Language.Egison.Math.Rewrite + ( rewriteSymbol + ) where + +import Control.Egison + +import Language.Egison.Math.Arith +import Language.Egison.Math.Expr +import Language.Egison.Math.Normalize + + +rewriteSymbol :: ScalarData -> ScalarData +rewriteSymbol = + foldl1 (\acc f -> f . acc) + [ rewriteI + , rewriteW + , rewriteLog + , rewriteSinCos + , rewriteExp + , rewritePower + , rewriteSqrt + , rewriteRt + , rewriteRtu + , rewriteDd + ] + +mapTerms :: (TermExpr -> TermExpr) -> ScalarData -> ScalarData +mapTerms f (Div (Plus ts1) (Plus ts2)) = + Div (Plus (map f ts1)) (Plus (map f ts2)) + +mapTerms' :: (TermExpr -> ScalarData) -> ScalarData -> ScalarData +mapTerms' f (Div (Plus ts1) (Plus ts2)) = + mathDiv (foldl1 mathPlus (map f ts1)) (foldl1 mathPlus (map f ts2)) + +mapPolys :: (PolyExpr -> PolyExpr) -> ScalarData -> ScalarData +mapPolys f (Div p1 p2) = Div (f p1) (f p2) + +rewriteI :: ScalarData -> ScalarData +rewriteI = mapTerms f + where + f term@(Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (symbol #"i", $k) : $xss -> + if even k + then Term (a * (-1) ^ (quot k 2)) xss + else Term (a * (-1) ^ (quot k 2)) ((Symbol "" "i" [], 1) : xss) |] + , [mc| _ -> term |] + ] + +rewriteW :: ScalarData -> ScalarData +rewriteW = mapPolys g . mapTerms f + where + f term@(Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (symbol #"w", $k & ?(>= 3)) : $xss -> + Term a ((Symbol "" "w" [], k `mod` 3) : xss) |] + , [mc| _ -> term |] + ] + g poly@(Plus ts) = + match dfs ts (Multiset TermM) + [ [mc| term $a ((symbol #"w", #2) : $mr) : + term $b ((symbol #"w", #1) : #mr) : $pr -> + g (Plus (Term (-a) mr : + Term (b - a) ((Symbol "" "w" [], 1) : mr) : pr)) |] + , [mc| _ -> poly |] + ] + +rewriteLog :: ScalarData -> ScalarData +rewriteLog = mapTerms f + where + f term@(Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"log" [zero], _) : _ -> Term 0 [] |] + , [mc| (apply #"log" [singleTerm _ #1 [(symbol #"e", $n)]], _) : $xss -> + Term (n * a) xss |] + , [mc| _ -> term |] + ] + +makeApply :: String -> [ScalarData] -> SymbolExpr +makeApply f args = + Apply (SingleSymbol (Symbol "" f [])) args + +rewriteExp :: ScalarData -> ScalarData +rewriteExp = mapTerms f + where + f term@(Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"exp" [zero], _) : $xss -> + f (Term a xss) |] + , [mc| (apply #"exp" [singleTerm #1 #1 []], _) : $xss -> + f (Term a ((Symbol "" "e" [], 1) : xss)) |] + , [mc| (apply #"exp" [singleTerm $n #1 [(symbol #"i", #1), (symbol #"π", #1)]], _) : $xss -> + f (Term ((-1) ^ n * a) xss) |] + , [mc| (apply #"exp" [$x], $n & ?(>= 2)) : $xss -> + f (Term a ((makeApply "exp" [mathScalarMult n x], 1) : xss)) |] + , [mc| (apply #"exp" [$x], #1) : (apply #"exp" [$y], #1) : $xss -> + f (Term a ((makeApply "exp" [mathPlus x y], 1) : xss)) |] + , [mc| _ -> term |] + ] + +rewritePower :: ScalarData -> ScalarData +rewritePower = mapTerms f + where + f term@(Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"^" [singleTerm #1 #1 [], _], _) : $xss -> f (Term a xss) |] + , [mc| (apply #"^" [$x, $y], $n & ?(>= 2)) : $xss -> + f (Term a ((makeApply "^" [x, mathScalarMult n y], 1) : xss)) |] + , [mc| (apply #"^" [$x, $y], #1) : (apply #"^" [#x, $z], #1) : $xss -> + f (Term a ((makeApply "^" [x, mathPlus y z], 1) : xss)) |] + , [mc| _ -> term |] + ] + +rewriteSinCos :: ScalarData -> ScalarData +rewriteSinCos = mapTerms' h . mapTerms (g . f) + where + f term@(Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"sin" [zero], _) : _ -> Term 0 [] |] + , [mc| (apply #"sin" [singleTerm _ #1 [(symbol #"π", #1)]], _) : _ -> + Term 0 [] |] + , [mc| (apply #"sin" [singleTerm $n #2 [(symbol #"π", #1)]], $m) : $xss -> + Term (a * (-1) ^ (div (abs n - 1) 2) * m) xss |] + , [mc| _ -> term |] + ] + g term@(Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"cos" [zero], _) : $xss -> Term a xss |] + , [mc| (apply #"cos" [singleTerm _ #2 [(symbol #"π", #1)]], _) : _ -> + Term 0 [] |] + , [mc| (apply #"cos" [singleTerm $n #1 [(symbol #"π", #1)]], $m) : $xss -> + Term (a * (-1) ^ (abs n * m)) xss |] + , [mc| _ -> term |] + ] + h (Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"cos" [$x], #2) : $mr -> + mathMult + (mathMinus (SingleTerm 1 []) (SingleTerm 1 [(makeApply "sin" [x], 2)])) + (h (Term a mr)) |] + , [mc| _ -> SingleTerm a xs |] + ] + +rewriteSqrt :: ScalarData -> ScalarData +rewriteSqrt = mapTerms' f + where + f (Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"sqrt" [$x], ?(> 1) & $k) : $xss -> + rewriteSqrt + (mathMult (SingleTerm a ((makeApply "sqrt" [x], k `mod` 2) : xss)) + (mathPower x (div k 2))) |] + , [mc| (apply #"sqrt" [singleTerm $n #1 $x], #1) : + (apply #"sqrt" [singleTerm $m #1 $y], #1) : $xss -> + 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)) |] + , [mc| _ -> SingleTerm a xs |] + ] + +rewriteRt :: ScalarData -> ScalarData +rewriteRt = mapTerms' f + where + f (Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"rt" [singleTerm $n #1 [], $x] & $rtnx, ?(>= n) & $k) : $xss -> + mathMult (SingleTerm a ((rtnx, k `mod` n) : xss)) + (mathPower x (div k n)) |] + , [mc| _ -> SingleTerm a xs |] + ] + +rewriteRtu :: ScalarData -> ScalarData +rewriteRtu = mapTerms f + where + f term@(Term a xs) = + match dfs xs (Multiset (Pair SymbolM Eql)) + [ [mc| (apply #"rtu" [singleTerm $n #1 []] & $rtun, ?(>= n) & $k) : $r -> + Term a ((rtun, k `mod` n) : r) |] + , [mc| _ -> term |] + ] + +rewriteDd :: ScalarData -> ScalarData +rewriteDd (Div (Plus p1) (Plus p2)) = + Div (Plus (rewriteDdPoly p1)) (Plus (rewriteDdPoly p2)) + 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 -> + rewriteDdPoly (Term (a + b) ((f, n) : mr) : pr) |] + , [mc| _ -> poly |] + ] diff --git a/hs-src/Language/Egison/MathExpr.hs b/hs-src/Language/Egison/MathExpr.hs deleted file mode 100644 --- a/hs-src/Language/Egison/MathExpr.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} - -{- | -Module : Language.Egison.MathExpr -Licence : MIT - -This module contains functions for mathematical expressions. --} - -module Language.Egison.MathExpr - ( - -- * MathExpr Data - ScalarData (..) - , PolyExpr (..) - , TermExpr (..) - , SymbolExpr (..) - , Printable (..) - , pattern ZeroExpr - , pattern SingleSymbol - , pattern SingleTerm - -- * Scalar - , mathNormalize' - , mathFold - , mathSymbolFold - , mathTermFold - , mathRemoveZero - , mathDivide - , mathPlus - , mathMult - , mathNegate - , mathNumerator - , mathDenominator - ) where - -import Prelude hiding (foldr, mappend, mconcat) -import Data.List (elemIndex, intercalate) - -import Language.Egison.AST - --- --- Data --- - - -data ScalarData - = Div PolyExpr PolyExpr - deriving (Eq) - -newtype PolyExpr - = Plus [TermExpr] - -data TermExpr - = Term Integer Monomial - --- We choose the definition 'monomials' without its coefficients. --- ex. 2 x^2 y^3 is *not* a monomial. x^2 t^3 is a monomial. -type Monomial = [(SymbolExpr, Integer)] - -data SymbolExpr - = Symbol Id String [Index ScalarData] - | Apply ScalarData [ScalarData] - | Quote ScalarData - | FunctionData ScalarData [ScalarData] [ScalarData] [Index ScalarData] -- fnname argnames args indices - deriving (Eq) - -type Id = String - -pattern ZeroExpr :: ScalarData -pattern ZeroExpr = (Div (Plus []) (Plus [Term 1 []])) - -pattern SingleSymbol :: SymbolExpr -> ScalarData -pattern SingleSymbol sym = Div (Plus [Term 1 [(sym, 1)]]) (Plus [Term 1 []]) - --- Product of a coefficient and a monomial -pattern SingleTerm :: Integer -> Monomial -> ScalarData -pattern SingleTerm coeff mono = Div (Plus [Term coeff mono]) (Plus [Term 1 []]) - -instance Eq PolyExpr where - (Plus []) == (Plus []) = True - (Plus (x:xs)) == (Plus ys) = - case elemIndex x ys of - Just i -> let (hs, _:ts) = splitAt i ys in - Plus xs == Plus (hs ++ ts) - Nothing -> False - _ == _ = False - -instance Eq TermExpr where - (Term a []) == (Term b []) = a == b - (Term a ((Quote x, n):xs)) == (Term b ys) - | (a /= b) && (a /= -b) = False - | otherwise = case elemIndex (Quote x, n) ys of - Just i -> let (hs, _:ts) = splitAt i ys in - Term a xs == Term b (hs ++ ts) - Nothing -> case elemIndex (Quote (mathNegate x), n) ys of - Just i -> let (hs, _:ts) = splitAt i ys in - if even n - then Term a xs == Term b (hs ++ ts) - else Term (-a) xs == Term b (hs ++ ts) - Nothing -> False - (Term a (x:xs)) == (Term b ys) - | (a /= b) && (a /= -b) = False - | otherwise = case elemIndex x ys of - Just i -> let (hs, _:ts) = splitAt i ys in - Term a xs == Term b (hs ++ ts) - Nothing -> False - _ == _ = False - -class Printable a where - isAtom :: a -> Bool - pretty :: a -> String - -pretty' :: Printable a => a -> String -pretty' e | isAtom e = pretty e -pretty' e = "(" ++ pretty e ++ ")" - -instance Printable ScalarData where - isAtom (Div p (Plus [Term 1 []])) = isAtom p - isAtom _ = False - - pretty (Div p1 (Plus [Term 1 []])) = pretty p1 - pretty (Div p1 p2) = pretty'' p1 ++ " / " ++ pretty' p2 - where - pretty'' :: PolyExpr -> String - pretty'' p@(Plus [_]) = pretty p - pretty'' p = "(" ++ pretty p ++ ")" - -instance Printable PolyExpr where - isAtom (Plus []) = True - isAtom (Plus [Term _ []]) = True - isAtom (Plus [Term 1 [_]]) = True - isAtom _ = False - - pretty (Plus []) = "0" - pretty (Plus (t:ts)) = pretty t ++ concatMap withSign ts - where - withSign (Term a xs) | a < 0 = " - " ++ pretty (Term (- a) xs) - withSign t = " + " ++ pretty t - -instance Printable SymbolExpr where - isAtom Symbol{} = True - isAtom (Apply _ []) = 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 - -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 (-1) xs) = "- " ++ intercalate " * " (map prettyPoweredSymbol xs) - pretty (Term a xs) = intercalate " * " (show a : map prettyPoweredSymbol xs) - -prettyPoweredSymbol :: (SymbolExpr, Integer) -> String -prettyPoweredSymbol (x, 1) = show x -prettyPoweredSymbol (x, n) = pretty' x ++ "^" ++ show n - -instance Show ScalarData where - show = pretty - -instance Show PolyExpr where - show = pretty - -instance Show TermExpr where - show = pretty - -instance Show SymbolExpr where - show = pretty - -instance Show (Index ScalarData) where - show (Superscript i) = "~" ++ pretty' i - show (Subscript i) = "_" ++ pretty' i - show (SupSubscript i) = "~_" ++ pretty' i - show (DFscript _ _) = "" - show (Userscript i) = "|" ++ pretty' i - --- --- Scalars --- - -mathNormalize' :: ScalarData -> ScalarData -mathNormalize' = mathDivide . mathRemoveZero . mathFold . mathRemoveZeroSymbol - -termsGcd :: [TermExpr] -> TermExpr -termsGcd ts@(_:_) = - foldl1 (\(Term a xs) (Term b ys) -> Term (gcd a b) (monoGcd xs ys)) ts - where - monoGcd :: Monomial -> Monomial -> Monomial - monoGcd [] _ = [] - monoGcd ((x, n):xs) ys = - case f (x, n) ys of - (_, 0) -> monoGcd xs ys - (z, m) -> (z, m) : monoGcd xs ys - - f :: (SymbolExpr, Integer) -> Monomial -> (SymbolExpr, Integer) - f (x, _) [] = (x, 0) - f (Quote x, n) ((Quote y, m):ys) - | x == y = (Quote x, min n m) - | x == mathNegate y = (Quote x, min n m) - | otherwise = f (Quote x, n) ys - f (x, n) ((y, m):ys) - | x == y = (x, min n m) - | otherwise = f (x, n) ys - -mathDivide :: ScalarData -> ScalarData -mathDivide mExpr@(Div (Plus _) (Plus [])) = mExpr -mathDivide mExpr@(Div (Plus []) (Plus _)) = mExpr -mathDivide (Div (Plus ts1) (Plus ts2)) = - let z@(Term c zs) = termsGcd (ts1 ++ ts2) in - case ts2 of - [Term a _] | a < 0 -> Div (Plus (map (`mathDivideTerm` Term (-c) zs) ts1)) - (Plus (map (`mathDivideTerm` Term (-c) zs) ts2)) - _ -> Div (Plus (map (`mathDivideTerm` z) ts1)) - (Plus (map (`mathDivideTerm` z) ts2)) - -mathDivideTerm :: TermExpr -> TermExpr -> TermExpr -mathDivideTerm (Term a xs) (Term b ys) = - let (sgn, zs) = f 1 xs ys in - Term (sgn * div a b) zs - where - f :: Integer -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Integer, [(SymbolExpr, Integer)]) - f sgn xs [] = (sgn, xs) - f sgn xs ((y, n):ys) = - let (sgns, zs) = unzip (map (\(x, m) -> g (x, m) (y, n)) xs) in - f (sgn * product sgns) zs ys - g :: (SymbolExpr, Integer) -> (SymbolExpr, Integer) -> (Integer, (SymbolExpr, Integer)) - g (Quote x, n) (Quote y, m) - | x == y = (1, (Quote x, n - m)) - | x == mathNegate y = if even m then (1, (Quote x, n - m)) else (-1, (Quote x, n - m)) - | otherwise = (1, (Quote x, n)) - g (x, n) (y, m) - | x == y = (1, (x, n - m)) - | otherwise = (1, (x, n)) - -mathRemoveZeroSymbol :: ScalarData -> ScalarData -mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) = - let ts1' = map (\(Term a xs) -> Term a (filter p xs)) ts1 - ts2' = map (\(Term a xs) -> Term a (filter p xs)) ts2 - in Div (Plus ts1') (Plus ts2') - where - p (_, 0) = False - p _ = True - -mathRemoveZero :: ScalarData -> ScalarData -mathRemoveZero (Div (Plus ts1) (Plus ts2)) = - let ts1' = filter (\(Term a _) -> a /= 0) ts1 in - let ts2' = filter (\(Term a _) -> a /= 0) ts2 in - case ts1' of - [] -> Div (Plus []) (Plus [Term 1 []]) - _ -> Div (Plus ts1') (Plus ts2') - -mathFold :: ScalarData -> ScalarData -mathFold = mathTermFold . mathSymbolFold . mathTermFold - --- x^2 y x -> x^3 y -mathSymbolFold :: ScalarData -> ScalarData -mathSymbolFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (map f ts1)) (Plus (map f ts2)) - where - f :: TermExpr -> TermExpr - f (Term a xs) = let (ys, sgns) = unzip $ g [] xs - in Term (product sgns * a) ys - g :: [((SymbolExpr, Integer),Integer)] -> [(SymbolExpr, Integer)] -> [((SymbolExpr, Integer),Integer)] - g ret [] = ret - g ret ((x, n):xs) - | any (p (x, n)) ret = g (map (h (x, n)) ret) xs - | otherwise = g (ret ++ [((x, n), 1)]) xs - p :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> Bool - p (Quote x, _) ((Quote y, _),_) = (x == y) || (mathNegate x == y) - p (x, _) ((y, _),_) = x == y - h :: (SymbolExpr, Integer) -> ((SymbolExpr, Integer), Integer) -> ((SymbolExpr, Integer), Integer) - h (Quote x, n) ((Quote y, m), sgn) - | x == y = ((Quote y, m + n), sgn) - | x == mathNegate y = if even n then ((Quote y, m + n), sgn) else ((Quote y, m + n), -1 * sgn) - | otherwise = ((Quote y, m), sgn) - h (x, n) ((y, m), sgn) = if x == y - then ((y, m + n), sgn) - else ((y, m), sgn) - --- x^2 y + x^2 y -> 2 x^2 y -mathTermFold :: ScalarData -> ScalarData -mathTermFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (f ts1)) (Plus (f ts2)) - where - f :: [TermExpr] -> [TermExpr] - f = f' [] - f' :: [TermExpr] -> [TermExpr] -> [TermExpr] - f' ret [] = ret - f' ret (Term a xs:ts) = - if any (\(Term _ ys) -> fst (p 1 xs ys)) ret - then f' (map (g (Term a xs)) ret) ts - else f' (ret ++ [Term a xs]) ts - g :: TermExpr -> TermExpr -> TermExpr - g (Term a xs) (Term b ys) = let (c, sgn) = p 1 xs ys in - if c - then Term ((sgn * a) + b) ys - else Term b ys - p :: Integer -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Bool, Integer) - p sgn [] [] = (True, sgn) - p _ [] _ = (False, 0) - p sgn ((x, n):xs) ys = - let (b, ys', sgn2) = q (x, n) [] ys in - if b - then p (sgn * sgn2) xs ys' - else (False, 0) - q :: (SymbolExpr, Integer) -> [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)] -> (Bool, [(SymbolExpr, Integer)], Integer) - q _ _ [] = (False, [], 1) - q (Quote x, n) ret ((Quote y, m):ys) - | (x == y) && (n == m) = (True, ret ++ ys, 1) - | (mathNegate x == y) && (n == m) = if even n then (True, ret ++ ys, 1) else (True, ret ++ ys, -1) - | otherwise = q (Quote x, n) (ret ++ [(Quote y, m)]) ys - q (Quote x, n) ret ((y,m):ys) = q (Quote x, n) (ret ++ [(y, m)]) ys - q (x, n) ret ((y, m):ys) = if (x == y) && (n == m) - then (True, ret ++ ys, 1) - else q (x, n) (ret ++ [(y, m)]) ys - --- --- Arithmetic operations --- - -mathPlus :: ScalarData -> ScalarData -> ScalarData -mathPlus (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathPlusPoly (mathMultPoly m1 n2) (mathMultPoly m2 n1)) (mathMultPoly n1 n2) - -mathPlusPoly :: PolyExpr -> PolyExpr -> PolyExpr -mathPlusPoly (Plus ts1) (Plus ts2) = Plus (ts1 ++ ts2) - -mathMult :: ScalarData -> ScalarData -> ScalarData -mathMult (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathMultPoly m1 m2) (mathMultPoly n1 n2) - -mathMultPoly :: PolyExpr -> PolyExpr -> PolyExpr -mathMultPoly (Plus []) (Plus _) = Plus [] -mathMultPoly (Plus _) (Plus []) = Plus [] -mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> Plus (map (\(Term b ys) -> Term (a * b) (xs ++ ys)) ts2)) ts1) - -mathNegate :: ScalarData -> ScalarData -mathNegate (Div m n) = Div (mathNegate' m) n - -mathNegate' :: PolyExpr -> PolyExpr -mathNegate' (Plus ts) = Plus (map (\(Term a xs) -> Term (-a) xs) ts) - -mathNumerator :: ScalarData -> ScalarData -mathNumerator (Div m _) = Div m (Plus [Term 1 []]) - -mathDenominator :: ScalarData -> ScalarData -mathDenominator (Div _ n) = Div n (Plus [Term 1 []]) diff --git a/hs-src/Language/Egison/MathOutput.hs b/hs-src/Language/Egison/MathOutput.hs --- a/hs-src/Language/Egison/MathOutput.hs +++ b/hs-src/Language/Egison/MathOutput.hs @@ -7,26 +7,23 @@ -} module Language.Egison.MathOutput - ( changeOutputInLang + ( prettyMath ) where -import Text.ParserCombinators.Parsec (parse) - +import Language.Egison.Data import Language.Egison.PrettyMath.AST import qualified Language.Egison.PrettyMath.AsciiMath as AsciiMath import qualified Language.Egison.PrettyMath.Latex as Latex import qualified Language.Egison.PrettyMath.Mathematica as Mathematica import qualified Language.Egison.PrettyMath.Maxima as Maxima -changeOutputInLang :: String -> String -> String -changeOutputInLang lang input = +prettyMath :: String -> EgisonValue -> String +prettyMath lang val = -- 'lang' is either "asciimath", "latex", "mathematica" or "maxima" -- Other invalid options are rejected in Interpreter/egison.hs - case parse parseExpr "math-expr" input of - Left _ -> input - Right val -> case showMathExpr lang val of - "undefined" -> "undefined" - output -> "#" ++ lang ++ "|" ++ output ++ "|#" + case showMathExpr lang (toMathExpr val) of + "undefined" -> "undefined" + output -> "#" ++ lang ++ "|" ++ output ++ "|#" showMathExpr :: String -> MathExpr -> String showMathExpr "asciimath" = AsciiMath.showMathExpr 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 @@ -7,12 +7,13 @@ module Language.Egison.Parser ( - -- * Parse and desugar + -- * Parse readTopExprs , readTopExpr , readExprs , readExpr - -- * Parse and desugar a file + , parseTopExpr + -- * Parse a file , loadLibraryFile , loadFile -- * Parser utils (for translator) @@ -20,46 +21,62 @@ , readUTF8File ) where -import Control.Monad.Except (liftIO, throwError) +import Control.Monad.Except (lift, liftIO, throwError) import Control.Monad.State (unless) +import Control.Monad.Reader (asks, local) import System.Directory (doesFileExist, getHomeDirectory) import System.IO import Language.Egison.AST -import Language.Egison.Desugar +import Language.Egison.CmdOptions import Language.Egison.Data +import Language.Egison.RState import qualified Language.Egison.Parser.SExpr as SExpr import qualified Language.Egison.Parser.NonS as NonS import Paths_egison (getDataFileName) -readTopExprs :: Bool -> String -> EvalM [EgisonTopExpr] -readTopExprs useSExpr = - either throwError (mapM desugarTopExpr) . parseTopExprs - where parseTopExprs | useSExpr = SExpr.parseTopExprs - | otherwise = NonS.parseTopExprs +readTopExprs :: String -> EvalM [TopExpr] +readTopExprs expr = do + isSExpr <- asks optSExpr + if isSExpr + then either (throwError . Parser) return (SExpr.parseTopExprs expr) + else do r <- lift . lift $ NonS.parseTopExprs expr + either (throwError . Parser) return r --- TODO(momohatt): Parse from the last state -readTopExpr :: Bool -> String -> EvalM EgisonTopExpr -readTopExpr useSExpr = - either throwError desugarTopExpr . parseTopExpr - where parseTopExpr | useSExpr = SExpr.parseTopExpr - | otherwise = NonS.parseTopExpr +parseTopExpr :: String -> RuntimeM (Either String TopExpr) +parseTopExpr expr = do + isSExpr <- asks optSExpr + if isSExpr + then return (SExpr.parseTopExpr expr) + else NonS.parseTopExpr expr -readExprs :: Bool -> String -> EvalM [EgisonExpr] -readExprs useSExpr = - either throwError (mapM desugarExpr) . parseExprs - where parseExprs | useSExpr = SExpr.parseExprs - | otherwise = NonS.parseExprs +readTopExpr :: String -> EvalM TopExpr +readTopExpr expr = do + isSExpr <- asks optSExpr + if isSExpr + then either (throwError . Parser) return (SExpr.parseTopExpr expr) + else do r <- lift . lift $ NonS.parseTopExpr expr + either (throwError . Parser) return r -readExpr :: Bool -> String -> EvalM EgisonExpr -readExpr useSExpr = - either throwError desugarExpr . parseExpr - where parseExpr | useSExpr = SExpr.parseExpr - | otherwise = NonS.parseExpr +readExprs :: String -> EvalM [Expr] +readExprs expr = do + isSExpr <- asks optSExpr + if isSExpr + then either (throwError . Parser) return (SExpr.parseExprs expr) + else do r <- lift . lift $ NonS.parseExprs expr + either (throwError . Parser) return r +readExpr :: String -> EvalM Expr +readExpr expr = do + isSExpr <- asks optSExpr + if isSExpr + then either (throwError . Parser) return (SExpr.parseExpr expr) + else do r <- lift . lift $ NonS.parseExpr expr + either (throwError . Parser) return r + -- |Load a libary file -loadLibraryFile :: FilePath -> EvalM [EgisonTopExpr] +loadLibraryFile :: FilePath -> EvalM [TopExpr] loadLibraryFile file = do homeDir <- liftIO getHomeDirectory doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file @@ -68,13 +85,14 @@ else liftIO (getDataFileName file) >>= loadFile -- |Load a file -loadFile :: FilePath -> EvalM [EgisonTopExpr] +loadFile :: FilePath -> EvalM [TopExpr] loadFile file = do doesExist <- liftIO $ doesFileExist file unless doesExist $ throwError $ Default ("file does not exist: " ++ file) input <- liftIO $ readUTF8File file - useSExpr <- checkIfUseSExpr file - exprs <- readTopExprs useSExpr $ removeShebang useSExpr input + let useSExpr = checkIfUseSExpr file + exprs <- local (\opt -> opt { optSExpr = useSExpr }) + (readTopExprs (removeShebang useSExpr input)) concat <$> mapM recursiveLoad exprs where recursiveLoad (Load file) = loadLibraryFile file @@ -91,14 +109,5 @@ hSetEncoding h utf8 hGetContents h -hasDotEgiExtension :: String -> Bool -hasDotEgiExtension file = drop (length file - 4) file == ".egi" - -hasDotSEgiExtension :: String -> Bool -hasDotSEgiExtension file = drop (length file - 5) file == ".segi" - -checkIfUseSExpr :: String -> EvalM Bool -checkIfUseSExpr file - | hasDotEgiExtension file = return False - | hasDotSEgiExtension file = return True - | otherwise = throwError (UnknownFileExtension file) +checkIfUseSExpr :: String -> Bool +checkIfUseSExpr file = drop (length file - 5) file == ".segi" 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 @@ -5,7 +5,7 @@ Module : Language.Egison.Parser.NonS Licence : MIT -This module provides the new parser of Egison. +This module provides the parser for the new syntax. -} module Language.Egison.Parser.NonS @@ -15,10 +15,11 @@ , parseTopExpr , parseExprs , parseExpr + , upperReservedWords + , lowerReservedWords ) where -import Control.Monad.Except (throwError) -import Control.Monad.State (evalStateT, get, put, StateT) +import Control.Monad.State (get, gets, put) import Data.Char (isAsciiUpper, isLetter) import Data.Either (isRight) @@ -32,40 +33,31 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L -import Language.Egison.AST -import Language.Egison.Data +import Language.Egison.AST hiding (Assoc(..)) +import qualified Language.Egison.AST as E +import Language.Egison.RState -parseTopExprs :: String -> Either EgisonError [EgisonTopExpr] + +parseTopExprs :: String -> RuntimeM (Either String [TopExpr]) parseTopExprs = doParse $ many (L.nonIndented sc topExpr) <* eof -parseTopExpr :: String -> Either EgisonError EgisonTopExpr +parseTopExpr :: String -> RuntimeM (Either String TopExpr) parseTopExpr = doParse $ sc >> topExpr <* eof -parseExprs :: String -> Either EgisonError [EgisonExpr] +parseExprs :: String -> RuntimeM (Either String [Expr]) parseExprs = doParse $ many (L.nonIndented sc expr) <* eof -parseExpr :: String -> Either EgisonError EgisonExpr +parseExpr :: String -> RuntimeM (Either String Expr) parseExpr = doParse $ sc >> expr <* eof -- -- Parser -- -type Parser = StateT PState (Parsec CustomError String) - --- Parser state -data PState - = PState { exprInfix :: [Infix] - , patternInfix :: [Infix] - } - -initialPState :: PState -initialPState = PState { exprInfix = reservedExprInfix - , patternInfix = reservedPatternInfix - } +type Parser = ParsecT CustomError String RuntimeM data CustomError - = IllFormedSection Infix Infix + = IllFormedSection Op Op | IllFormedDefine | LastStmtInDoBlock deriving (Eq, Ord) @@ -82,53 +74,50 @@ "The last statement in a 'do' block must be an expression." -doParse :: Parser a -> String -> Either EgisonError a -doParse p input = - case parse (evalStateT p initialPState) "egison" input of - Left e -> throwError (Parser (errorBundlePretty e)) - Right r -> return r +doParse :: Parser a -> String -> RuntimeM (Either String a) +doParse p input = do + result <- runParserT p "egison" input + case result of + Left e -> return $ Left (errorBundlePretty e) + Right r -> return $ Right r -- -- Expressions -- -topExpr :: Parser EgisonTopExpr +topExpr :: Parser TopExpr topExpr = Load <$> (reserved "load" >> stringLiteral) <|> LoadFile <$> (reserved "loadFile" >> stringLiteral) <|> Execute <$> (reserved "execute" >> expr) + <|> (reserved "def" >> defineExpr) <|> infixExpr - <|> defineOrTestExpr + <|> Test <$> expr "toplevel expression" --- Return type of |convertToDefine|. -data ConversionResult - = Variable Var -- Definition of a variable with no arguments on lhs. - | Function Var [Arg] -- Definition of a function with some arguments on lhs. - | IndexedVar VarWithIndices - -- Sort binaryop table on the insertion -addNewOp :: Infix -> Bool -> Parser () -addNewOp newop isPattern = do +addNewOp :: Op -> Bool -> Parser () +addNewOp newop isPattern | isPattern = do pstate <- get - put $! if isPattern - then pstate { patternInfix = insertBy - (\x y -> compare (priority y) (priority x)) - newop - (patternInfix pstate) } - else pstate { exprInfix = insertBy - (\x y -> compare (priority y) (priority x)) - newop - (exprInfix pstate) } + put $! pstate { patternOps = insertBy + (\x y -> compare (priority y) (priority x)) + newop + (patternOps pstate) } +addNewOp newop _ = do + pstate <- get + put $! pstate { exprOps = insertBy + (\x y -> compare (priority y) (priority x)) + newop + (exprOps pstate) } -infixExpr :: Parser EgisonTopExpr +infixExpr :: Parser TopExpr infixExpr = do - assoc <- (reserved "infixl" $> LeftAssoc) - <|> (reserved "infixr" $> RightAssoc) - <|> (reserved "infix" $> NonAssoc) + assoc <- (reserved "infixl" $> E.InfixL) + <|> (reserved "infixr" $> E.InfixR) + <|> (reserved "infix" $> E.InfixN) isPattern <- isRight <$> eitherP (reserved "expression") (reserved "pattern") priority <- fromInteger <$> positiveIntegerLiteral sym <- if isPattern then newPatOp >>= checkP else some opChar >>= check - let newop = Infix { repr = sym, func = sym, priority, assoc, isWedge = False } + let newop = Op { repr = sym, priority, assoc, isWedge = False } addNewOp newop isPattern return (InfixDecl isPattern newop) where @@ -145,78 +134,19 @@ reservedOp = [":", ":=", "->"] reservedPOp = ["&", "|", ":=", "->"] -defineOrTestExpr :: Parser EgisonTopExpr -defineOrTestExpr = do - e <- expr - defineExpr e <|> return (Test e) - where - defineExpr :: EgisonExpr -> Parser EgisonTopExpr - defineExpr e = do - _ <- symbol ":=" - -- When ":=" is observed and the current expression turns out to be a - -- definition, we do not start over from scratch but re-interpret - -- what's parsed so far as the lhs of definition. - case convertToDefine e of - Nothing -> customFailure IllFormedDefine - Just (Variable var) -> Define var <$> expr - Just (Function var args) -> Define var . LambdaExpr args <$> expr - Just (IndexedVar var) -> DefineWithIndices var <$> expr - - convertToDefine :: EgisonExpr -> Maybe ConversionResult - convertToDefine (VarExpr var) = return $ Variable var - convertToDefine (SectionExpr op Nothing Nothing) = - return $ Variable (stringToVar (func op)) - convertToDefine (ApplyExpr (VarExpr var) (TupleExpr [TupleExpr args])) = do - args' <- mapM ((TensorArg <$>) . exprToStr) args - return $ Function var args' - convertToDefine (ApplyExpr (VarExpr var) (TupleExpr args)) = do - args' <- mapM ((TensorArg <$>) . exprToStr) args - return $ Function var args' - convertToDefine (ApplyExpr (SectionExpr op Nothing Nothing) (TupleExpr [x, y])) = do - args <- mapM ((TensorArg <$>) . exprToStr) [x, y] - return $ Function (stringToVar (repr op)) args - convertToDefine e@(InfixExpr op _ _) - | repr op == "*" || repr op == "%" || repr op == "$" = do - args <- exprToArgs e - case args of - TensorArg var : args -> return $ Function (stringToVar var) args - _ -> Nothing - convertToDefine (IndexedExpr True (VarExpr (Var var [])) indices) = do - -- [Index EgisonExpr] -> Maybe [Index String] - indices' <- mapM (traverse exprToStr) indices - return $ IndexedVar (VarWithIndices var indices') - convertToDefine _ = Nothing - - exprToStr :: EgisonExpr -> Maybe String - exprToStr (VarExpr v) = Just (show v) - exprToStr _ = Nothing - - exprToArgs :: EgisonExpr -> Maybe [Arg] - exprToArgs (VarExpr v) = return [TensorArg (show v)] - exprToArgs (ApplyExpr func (TupleExpr args)) = - (++) <$> exprToArgs func <*> mapM ((TensorArg <$>) . exprToStr) args - exprToArgs (SectionExpr op Nothing Nothing) = return [TensorArg (func op)] - exprToArgs (InfixExpr op lhs rhs) | repr op == "*" = do - lhs' <- exprToArgs lhs - rhs' <- exprToArgs rhs - case rhs' of - TensorArg x : xs -> return (lhs' ++ InvertedScalarArg x : xs) - _ -> Nothing - exprToArgs (InfixExpr op lhs rhs) | repr op == "$" = do - lhs' <- exprToArgs lhs - rhs' <- exprToArgs rhs - case rhs' of - TensorArg x : xs -> return (lhs' ++ ScalarArg x : xs) - _ -> Nothing - exprToArgs (InfixExpr op lhs rhs) | repr op == "%" = do - lhs' <- exprToArgs lhs - rhs' <- exprToArgs rhs - case rhs' of - TensorArg _ : _ -> return (lhs' ++ rhs') - _ -> Nothing - exprToArgs _ = Nothing +defineExpr :: Parser TopExpr +defineExpr = do + ops <- gets exprOps + f <- parens (stringToVarWithIndices . repr <$> choice (map (infixLiteral . repr) ops)) + <|> varWithIndicesLiteral + args <- many arg + _ <- symbol ":=" + body <- expr + case args of + [] -> return (Define f body) + _ -> return (Define f (LambdaExpr args body)) -expr :: Parser EgisonExpr +expr :: Parser Expr expr = do body <- exprWithoutWhere bindings <- optional (reserved "where" >> alignSome binding) @@ -224,8 +154,12 @@ Nothing -> body Just bindings -> LetRecExpr bindings body -exprWithoutWhere :: Parser EgisonExpr -exprWithoutWhere = +exprWithoutWhere :: Parser Expr +exprWithoutWhere = opExpr + +-- Expressions that can be the arguments for the operators. +exprInOp :: Parser Expr +exprInOp = ifExpr <|> patternMatchExpr <|> lambdaExpr @@ -233,7 +167,6 @@ <|> letExpr <|> withSymbolsExpr <|> doExpr - <|> ioExpr <|> seqExpr <|> capplyExpr <|> matcherExpr @@ -241,44 +174,43 @@ <|> tensorExpr <|> functionExpr <|> refsExpr - <|> opExpr + <|> atomOrApplyExpr "expression" --- Also parses atomExpr -opExpr :: Parser EgisonExpr +-- Also parses exprInOp +opExpr :: Parser Expr opExpr = do - infixes <- exprInfix <$> get - makeExprParser atomOrApplyExpr (makeExprTable infixes) + ops <- gets exprOps + makeExprParser exprInOp (makeExprTable ops) -makeExprTable :: [Infix] -> [[Operator Parser EgisonExpr]] -makeExprTable infixes = - -- prefixes have top priority - let prefixes = [ [ Prefix (unary "-") - , Prefix (unary "!") ] ] - -- Generate binary operator table from |infixes| - infixes' = map (map toOperator) - (groupBy (\x y -> priority x == priority y) infixes) - in prefixes ++ infixes' +makeExprTable :: [Op] -> [[Operator Parser Expr]] +makeExprTable ops = + -- Generate binary operator table from |ops| + map (map toOperator) (groupBy (\x y -> priority x == priority y) ops) where -- notFollowedBy (in unary and binary) is necessary for section expression. - unary :: String -> Parser (EgisonExpr -> EgisonExpr) + unary :: String -> Parser (Expr -> Expr) unary sym = PrefixExpr <$> try (operator sym <* notFollowedBy (symbol ")")) - binary :: Infix -> Parser (EgisonExpr -> EgisonExpr -> EgisonExpr) + binary :: Op -> Parser (Expr -> Expr -> Expr) binary op = do -- Operators should be indented than pos1 in order to avoid -- "1\n-2" (2 topExprs, 1 and -2) to be parsed as "1 - 2". op <- try (indented >> infixLiteral (repr op) <* notFollowedBy (symbol ")")) return $ InfixExpr op - toOperator :: Infix -> Operator Parser EgisonExpr - toOperator = infixToOperator binary - + toOperator :: Op -> Operator Parser Expr + toOperator op = + case assoc op of + E.InfixL -> InfixL (binary op) + E.InfixR -> InfixR (binary op) + E.InfixN -> InfixN (binary op) + E.Prefix -> Prefix (unary (repr op)) -ifExpr :: Parser EgisonExpr +ifExpr :: Parser Expr ifExpr = reserved "if" >> IfExpr <$> expr <* reserved "then" <*> expr <* reserved "else" <*> expr -patternMatchExpr :: Parser EgisonExpr +patternMatchExpr :: Parser Expr patternMatchExpr = makeMatchExpr (reserved "match") (MatchExpr BFSMode) <|> makeMatchExpr (reserved "matchDFS") (MatchExpr DFSMode) <|> makeMatchExpr (reserved "matchAll") (MatchAllExpr BFSMode) @@ -301,11 +233,11 @@ matchClause :: Parser MatchClause matchClause = (,) <$> (symbol "|" >> pattern) <*> (symbol "->" >> expr) -lambdaExpr :: Parser EgisonExpr +lambdaExpr :: Parser Expr lambdaExpr = symbol "\\" >> ( makeMatchLambdaExpr (reserved "match") MatchLambdaExpr <|> makeMatchLambdaExpr (reserved "matchAll") MatchAllLambdaExpr - <|> try (LambdaExpr <$> tupleOrSome arg <* symbol "->") <*> expr + <|> try (LambdaExpr <$> some arg <* symbol "->") <*> expr <|> PatternFunctionExpr <$> tupleOrSome lowerId <*> (symbol "=>" >> pattern)) "lambda or pattern function expression" where @@ -314,19 +246,29 @@ clauses <- reserved "with" >> matchClauses1 return $ ctor matcher clauses -lambdaLikeExpr :: Parser EgisonExpr +lambdaLikeExpr :: Parser Expr lambdaLikeExpr = (reserved "memoizedLambda" >> MemoizedLambdaExpr <$> tupleOrSome lowerId <*> (symbol "->" >> expr)) <|> (reserved "cambda" >> CambdaExpr <$> lowerId <*> (symbol "->" >> expr)) -arg :: Parser Arg -arg = InvertedScalarArg <$> (char '*' >> ident) - <|> TensorArg <$> (char '%' >> ident) - <|> ScalarArg <$> (char '$' >> ident) - <|> TensorArg <$> ident +arg :: Parser (Arg ArgPattern) +arg = InvertedScalarArg <$> (string "*$" >> argPatternAtom) + <|> TensorArg <$> (char '%' >> argPatternAtom) + <|> ScalarArg <$> (char '$' >> argPatternAtom) + <|> TensorArg <$> argPattern "argument" -letExpr :: Parser EgisonExpr +argPattern :: Parser ArgPattern +argPattern = + argPatternAtom + +argPatternAtom :: Parser ArgPattern +argPatternAtom + = APWildCard <$ symbol "_" + <|> APTuplePat <$> parens (sepBy arg comma) + <|> APPatVar <$> ident + +letExpr :: Parser Expr letExpr = do binds <- reserved "let" >> oneLiner <|> alignSome binding body <- reserved "in" >> expr @@ -337,42 +279,39 @@ binding :: Parser BindingExpr binding = do - (vars, args) <- (,[]) <$> parens (sepBy varLiteral comma) - <|> do var <- varLiteral - args <- many arg - return ([var], args) + id <- Left <$> try varWithIndicesLiteral' <|> Right <$> pdAtom + args <- many arg body <- symbol ":=" >> expr - return $ case args of - [] -> (vars, body) - _ -> (vars, LambdaExpr args body) + case (id, args) of + (Left var, []) -> return $ BindWithIndices var body + (Right pdp, []) -> return $ Bind pdp body + (Right pdp, _) -> return $ Bind pdp (LambdaExpr args body) + _ -> error "unreachable" -withSymbolsExpr :: Parser EgisonExpr +withSymbolsExpr :: Parser Expr withSymbolsExpr = WithSymbolsExpr <$> (reserved "withSymbols" >> brackets (sepBy ident comma)) <*> expr -doExpr :: Parser EgisonExpr +doExpr :: Parser Expr doExpr = do stmts <- reserved "do" >> oneLiner <|> alignSome statement case reverse stmts of - [] -> return $ DoExpr [] (makeApply' "return" []) - ([], expr):_ -> return $ DoExpr (init stmts) expr - _:_ -> customFailure LastStmtInDoBlock + [] -> return $ DoExpr [] (makeApply "return" []) + Bind (PDTuplePat []) expr:_ -> return $ DoExpr (init stmts) expr + _:_ -> customFailure LastStmtInDoBlock where statement :: Parser BindingExpr - statement = (reserved "let" >> binding) <|> ([],) <$> expr + statement = (reserved "let" >> binding) <|> Bind (PDTuplePat []) <$> expr oneLiner :: Parser [BindingExpr] oneLiner = braces $ sepBy statement (symbol ";") -ioExpr :: Parser EgisonExpr -ioExpr = IoExpr <$> (reserved "io" >> expr) - -seqExpr :: Parser EgisonExpr +seqExpr :: Parser Expr seqExpr = SeqExpr <$> (reserved "seq" >> atomExpr) <*> atomExpr -capplyExpr :: Parser EgisonExpr +capplyExpr :: Parser Expr capplyExpr = CApplyExpr <$> (reserved "capply" >> atomExpr) <*> atomExpr -matcherExpr :: Parser EgisonExpr +matcherExpr :: Parser Expr matcherExpr = do reserved "matcher" -- Assuming it is unlikely that users want to write matchers with only 1 @@ -380,24 +319,24 @@ -- expression. MatcherExpr <$> alignSome (symbol "|" >> patternDef) where - patternDef :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)]) + patternDef :: Parser (PrimitivePatPattern, Expr, [(PrimitiveDataPattern, Expr)]) patternDef = do pp <- ppPattern returnMatcher <- reserved "as" >> expr <* reserved "with" datapat <- alignSome (symbol "|" >> dataCases) return (pp, returnMatcher, datapat) - dataCases :: Parser (PrimitiveDataPattern, EgisonExpr) + dataCases :: Parser (PrimitiveDataPattern, Expr) dataCases = (,) <$> pdPattern <*> (symbol "->" >> expr) -algebraicDataMatcherExpr :: Parser EgisonExpr +algebraicDataMatcherExpr :: Parser Expr algebraicDataMatcherExpr = do reserved "algebraicDataMatcher" AlgebraicDataMatcherExpr <$> alignSome (symbol "|" >> patternDef) where patternDef = indentBlock lowerId atomExpr -tensorExpr :: Parser EgisonExpr +tensorExpr :: Parser Expr tensorExpr = (reserved "tensor" >> TensorExpr <$> atomExpr <*> atomExpr) <|> (reserved "generateTensor" >> GenerateTensorExpr <$> atomExpr <*> atomExpr) @@ -406,10 +345,10 @@ <|> (reserved "tensorMap2" >> TensorMap2Expr <$> atomExpr <*> atomExpr <*> atomExpr) <|> (reserved "transpose" >> TransposeExpr <$> atomExpr <*> atomExpr) -functionExpr :: Parser EgisonExpr -functionExpr = FunctionExpr <$> (reserved "function" >> parens (sepBy expr comma)) +functionExpr :: Parser Expr +functionExpr = FunctionExpr <$> (reserved "function" >> parens (sepBy ident comma)) -refsExpr :: Parser EgisonExpr +refsExpr :: Parser Expr refsExpr = (reserved "subrefs" >> SubrefsExpr False <$> atomExpr <*> atomExpr) <|> (reserved "subrefs!" >> SubrefsExpr True <$> atomExpr <*> atomExpr) @@ -418,109 +357,110 @@ <|> (reserved "userRefs" >> UserrefsExpr False <$> atomExpr <*> atomExpr) <|> (reserved "userRefs!" >> UserrefsExpr True <$> atomExpr <*> atomExpr) -collectionExpr :: Parser EgisonExpr +collectionExpr :: Parser Expr collectionExpr = symbol "[" >> betweenOrFromExpr <|> elementsExpr where betweenOrFromExpr = do start <- try (expr <* symbol "..") end <- optional expr <* symbol "]" case end of - Just end' -> return $ makeApply' "between" [start, end'] - Nothing -> return $ makeApply' "from" [start] + Just end' -> return $ makeApply "between" [start, end'] + Nothing -> return $ makeApply "from" [start] - elementsExpr = CollectionExpr <$> (sepBy (ElementExpr <$> expr) comma <* symbol "]") + elementsExpr = CollectionExpr <$> (sepBy expr comma <* symbol "]") -- Parse an atomic expression starting with '(', which can be: -- * a tuple -- * an arbitrary expression wrapped with parenthesis -- * section -tupleOrParenExpr :: Parser EgisonExpr +tupleOrParenExpr :: Parser Expr tupleOrParenExpr = do elems <- symbol "(" >> try (sepBy expr comma <* symbol ")") <|> (section <* symbol ")") case elems of [x] -> return x -- expression wrapped in parenthesis _ -> return $ TupleExpr elems -- tuple where - section :: Parser [EgisonExpr] + section :: Parser [Expr] -- Start from right, in order to parse expressions like (-1 +) correctly section = (:[]) <$> (rightSection <|> leftSection) -- Sections without the left operand: eg. (+), (+ 1) - leftSection :: Parser EgisonExpr + leftSection :: Parser Expr leftSection = do - infixes <- exprInfix <$> get - op <- choice $ map (infixLiteral . repr) infixes - rarg <- optional expr + ops <- gets exprOps + op <- choice $ map (infixLiteral . repr) ops + rarg <- optional expr case rarg of - Just (InfixExpr op' _ _) - | assoc op' /= RightAssoc && priority op >= priority op' -> - customFailure (IllFormedSection op op') + -- Disabling for now... (See issue 159) + -- Just (InfixExpr op' _ _) + -- | assoc op' /= InfixR && priority op >= priority op' -> + -- customFailure (IllFormedSection op op') _ -> return (SectionExpr op Nothing rarg) -- Sections with the left operand but lacks the right operand: eg. (1 +) - rightSection :: Parser EgisonExpr + rightSection :: Parser Expr rightSection = do - infixes <- exprInfix <$> get - larg <- opExpr - op <- choice $ map (infixLiteral . repr) infixes + ops <- gets exprOps + larg <- opExpr + op <- choice $ map (infixLiteral . repr) ops case larg of - InfixExpr op' _ _ - | assoc op' /= LeftAssoc && priority op >= priority op' -> - customFailure (IllFormedSection op op') + -- InfixExpr op' _ _ + -- | assoc op' /= InfixL && priority op >= priority op' -> + -- customFailure (IllFormedSection op op') _ -> return (SectionExpr op (Just larg) Nothing) -vectorExpr :: Parser EgisonExpr +vectorExpr :: Parser Expr vectorExpr = VectorExpr <$> between (symbol "[|") (symbol "|]") (sepEndBy expr comma) -hashExpr :: Parser EgisonExpr +hashExpr :: Parser Expr hashExpr = HashExpr <$> hashBraces (sepEndBy hashElem comma) where hashBraces = between (symbol "{|") (symbol "|}") hashElem = parens $ (,) <$> expr <*> (comma >> expr) -index :: Parser (Index EgisonExpr) -index = SupSubscript <$> (string "~_" >> atomExpr') +index :: Parser a -> Parser (IndexExpr a) +index p = SupSubscript <$> (string "~_" >> p) <|> try (char '_' >> subscript) <|> try (char '~' >> superscript) - <|> try (Userscript <$> (char '|' >> atomExpr')) + <|> try (Userscript <$> (char '|' >> p)) "index" where subscript = do - e1 <- atomExpr' - e2 <- optional (string "..._" >> atomExpr') + e1 <- p + e2 <- optional (string "..._" >> p) case e2 of Nothing -> return $ Subscript e1 Just e2' -> return $ MultiSubscript e1 e2' superscript = do - e1 <- atomExpr' - e2 <- optional (string "...~" >> atomExpr') + e1 <- p + e2 <- optional (string "...~" >> p) case e2 of Nothing -> return $ Superscript e1 Just e2' -> return $ MultiSuperscript e1 e2' -atomOrApplyExpr :: Parser EgisonExpr +atomOrApplyExpr :: Parser Expr atomOrApplyExpr = do (func, args) <- indentBlock atomExpr atomExpr return $ case args of [] -> func - _ -> makeApply func args + _ -> ApplyExpr func args -- (Possibly indexed) atomic expressions -atomExpr :: Parser EgisonExpr +atomExpr :: Parser Expr atomExpr = do e <- atomExpr' - override <- isNothing <$> optional (try (string "..." <* lookAhead index)) - indices <- many index + override <- isNothing <$> optional (try (string "..." <* lookAhead (index atomExpr'))) + indices <- many (index atomExpr') return $ case indices of [] -> e _ -> IndexedExpr override e indices -- Atomic expressions without index -atomExpr' :: Parser EgisonExpr +atomExpr' :: Parser Expr atomExpr' = anonParamFuncExpr -- must come before |constantExpr| - <|> constantExpr + <|> ConstantExpr <$> constantExpr <|> FreshVarExpr <$ symbol "#" - <|> VarExpr <$> varLiteral + <|> VarExpr <$> ident <|> vectorExpr -- must come before |collectionExpr| <|> collectionExpr <|> tupleOrParenExpr @@ -530,13 +470,13 @@ <|> AnonParamExpr <$> try (char '%' >> positiveIntegerLiteral) "atomic expression" -anonParamFuncExpr :: Parser EgisonExpr +anonParamFuncExpr :: Parser Expr anonParamFuncExpr = do n <- try (L.decimal <* char '#') -- No space after the index body <- atomExpr -- No space after '#' return $ AnonParamFuncExpr n body -constantExpr :: Parser EgisonExpr +constantExpr :: Parser ConstantExpr constantExpr = numericExpr <|> BoolExpr <$> boolLiteral <|> CharExpr <$> try charLiteral -- try for quoteExpr @@ -544,7 +484,7 @@ <|> SomethingExpr <$ reserved "something" <|> UndefinedExpr <$ reserved "undefined" -numericExpr :: Parser EgisonExpr +numericExpr :: Parser ConstantExpr numericExpr = FloatExpr <$> try positiveFloatLiteral <|> IntegerExpr <$> positiveIntegerLiteral "numeric expression" @@ -552,24 +492,24 @@ -- Pattern -- -pattern :: Parser EgisonPattern +pattern :: Parser Pattern pattern = letPattern <|> forallPattern <|> loopPattern <|> opPattern "pattern" -letPattern :: Parser EgisonPattern +letPattern :: Parser Pattern letPattern = reserved "let" >> LetPat <$> alignSome binding <*> (reserved "in" >> pattern) -forallPattern :: Parser EgisonPattern +forallPattern :: Parser Pattern forallPattern = reserved "forall" >> ForallPat <$> atomPattern <*> atomPattern -loopPattern :: Parser EgisonPattern +loopPattern :: Parser Pattern loopPattern = - LoopPat <$> (reserved "loop" >> patVarLiteral) <*> loopRange + LoopPat <$> (reserved "loop" >> char '$' >> ident) <*> loopRange <*> atomPattern <*> atomPattern where loopRange :: Parser LoopRange @@ -580,33 +520,33 @@ return $ LoopRange start ends as defaultEnds s = - ApplyExpr (stringToVarExpr "from") - (makeApply (stringToVarExpr "-'") [s, IntegerExpr 1]) + makeApply "from" + [makeApply "-'" [s, ConstantExpr (IntegerExpr 1)]] -seqPattern :: Parser EgisonPattern +seqPattern :: Parser Pattern seqPattern = do pats <- braces $ sepBy pattern comma return $ foldr SeqConsPat SeqNilPat pats -opPattern :: Parser EgisonPattern +opPattern :: Parser Pattern opPattern = do - ops <- patternInfix <$> get + ops <- gets patternOps makeExprParser applyOrAtomPattern (makePatternTable ops) -makePatternTable :: [Infix] -> [[Operator Parser EgisonPattern]] +makePatternTable :: [Op] -> [[Operator Parser Pattern]] makePatternTable ops = - let infixes = map toOperator ops - in map (map snd) (groupBy (\x y -> fst x == fst y) infixes) + let ops' = map toOperator ops + in map (map snd) (groupBy (\x y -> fst x == fst y) ops') where - toOperator :: Infix -> (Int, Operator Parser EgisonPattern) + toOperator :: Op -> (Int, Operator Parser Pattern) toOperator op = (priority op, infixToOperator binary op) - binary :: Infix -> Parser (EgisonPattern -> EgisonPattern -> EgisonPattern) + binary :: Op -> Parser (Pattern -> Pattern -> Pattern) binary op = do op <- try (indented >> patInfixLiteral (repr op)) return $ InfixPat op -applyOrAtomPattern :: Parser EgisonPattern +applyOrAtomPattern :: Parser Pattern applyOrAtomPattern = (do (func, args) <- indentBlock (try atomPattern) atomPattern case (func, args) of @@ -617,16 +557,16 @@ (func, args) <- indentBlock atomExpr atomPattern return $ PApplyPat func args) -collectionPattern :: Parser EgisonPattern +collectionPattern :: Parser Pattern collectionPattern = brackets $ do elems <- sepBy pattern comma return $ foldr (InfixPat consOp) nilPat elems where nilPat = InductivePat "nil" [] - consOp = findOpFrom "::" reservedPatternInfix + consOp = findOpFrom "::" reservedPatternOp -- (Possibly indexed) atomic pattern -atomPattern :: Parser EgisonPattern +atomPattern :: Parser Pattern atomPattern = do pat <- atomPattern' indices <- many . try $ char '_' >> atomExpr' @@ -635,7 +575,7 @@ _ -> IndexedPat pat indices -- Atomic pattern without index -atomPattern' :: Parser EgisonPattern +atomPattern' :: Parser Pattern atomPattern' = WildCard <$ symbol "_" <|> PatVar <$> patVarLiteral <|> NotPat <$> (symbol "!" >> atomPattern) @@ -652,18 +592,18 @@ ppPattern :: Parser PrimitivePatPattern ppPattern = PPInductivePat <$> lowerId <*> many ppAtom - <|> do ops <- patternInfix <$> get + <|> do ops <- gets patternOps makeExprParser ppAtom (makeTable ops) "primitive pattern pattern" where - makeTable :: [Infix] -> [[Operator Parser PrimitivePatPattern]] + makeTable :: [Op] -> [[Operator Parser PrimitivePatPattern]] makeTable ops = map (map toOperator) (groupBy (\x y -> priority x == priority y) ops) - toOperator :: Infix -> Operator Parser PrimitivePatPattern + toOperator :: Op -> Operator Parser PrimitivePatPattern toOperator = infixToOperator inductive2 - inductive2 op = (\x y -> PPInductivePat (func op) [x, y]) <$ operator (repr op) + inductive2 op = (\x y -> PPInductivePat (repr op) [x, y]) <$ operator (repr op) ppAtom :: Parser PrimitivePatPattern ppAtom = PPWildCard <$ symbol "_" @@ -686,18 +626,19 @@ <|> PDSnocPat <$> (symbol "snoc" >> pdAtom) <*> pdAtom <|> pdAtom +pdAtom :: Parser PrimitiveDataPattern +pdAtom = PDWildCard <$ symbol "_" + <|> PDPatVar <$> patVarLiteral + <|> PDPatVar <$> ident + <|> PDConstantPat <$> constantExpr + <|> pdCollection + <|> makeTupleOrParen pdPattern PDTuplePat + where pdCollection :: Parser PrimitiveDataPattern pdCollection = do elts <- brackets (sepBy pdPattern comma) return (foldr PDConsPat PDEmptyPat elts) - pdAtom :: Parser PrimitiveDataPattern - pdAtom = PDWildCard <$ symbol "_" - <|> PDPatVar <$> (char '$' >> ident) - <|> PDConstantPat <$> constantExpr - <|> pdCollection - <|> makeTupleOrParen pdPattern PDTuplePat - -- -- Tokens -- @@ -733,20 +674,32 @@ positiveFloatLiteral = lexeme L.float "unsigned float" -varLiteral :: Parser Var -varLiteral = stringToVar <$> ident +varWithIndicesLiteral :: Parser VarWithIndices +varWithIndicesLiteral = + lexeme (VarWithIndices <$> ident' <*> many varIndex) -patVarLiteral :: Parser Var -patVarLiteral = stringToVar <$> (char '$' >> ident) +varWithIndicesLiteral' :: Parser VarWithIndices +varWithIndicesLiteral' = + lexeme (VarWithIndices <$> ident' <*> some varIndex) +varIndex :: Parser VarIndex +varIndex = (char '_' >> VSubscript <$> ident') + <|> (char '~' >> VSuperscript <$> ident') + <|> parens (VGroupScripts <$> some varIndex) + <|> braces (VSymmScripts <$> some varIndex) + <|> brackets (VAntiSymmScripts <$> some varIndex) + +patVarLiteral :: Parser String +patVarLiteral = char '$' >> ident + -- Parse infix (binary operator) literal. -- If the operator is prefixed with '!', |isWedge| is turned to true. -infixLiteral :: String -> Parser Infix +infixLiteral :: String -> Parser Op infixLiteral sym = - try (do wedge <- optional (char '!') - opSym <- operator' sym - infixes <- exprInfix <$> get - let opInfo = findOpFrom opSym infixes + try (do wedge <- optional (char '!') + opSym <- operator' sym + ops <- gets exprOps + let opInfo = findOpFrom opSym ops return $ opInfo { isWedge = isJust wedge }) "infix" where @@ -764,11 +717,11 @@ operator sym = try $ string sym <* notFollowedBy opChar <* sc -- |infixLiteral| for pattern infixes. -patInfixLiteral :: String -> Parser Infix +patInfixLiteral :: String -> Parser Op patInfixLiteral sym = try (do opSym <- string sym <* notFollowedBy patOpChar <* sc - infixes <- patternInfix <$> get - let opInfo = findOpFrom opSym infixes + ops <- gets patternOps + let opInfo = findOpFrom opSym ops return opInfo) -- Characters that can consist expression operators. @@ -847,6 +800,16 @@ then fail $ "keyword " ++ show x ++ " cannot be an identifier" else return x +-- |ident| not followed by a space +ident' :: Parser String +ident' = try (p >>= check) + where + p = (:) <$> satisfy checkHead <*> identString + checkHead c = c `elem` mathSymbols || isLetter c + check x = if x `elem` (lowerReservedWords ++ upperReservedWords) + then fail $ "keyword " ++ show x ++ " cannot be an identifier" + else return x + upperReservedWords :: [String] upperReservedWords = [ "True" @@ -857,6 +820,7 @@ lowerReservedWords = [ "loadFile" , "load" + , "def" , "if" , "then" , "else" @@ -878,7 +842,6 @@ , "with" , "matcher" , "do" - , "io" , "something" , "undefined" , "algebraicDataMatcher" @@ -911,13 +874,6 @@ [elem] -> return elem _ -> return $ tupleCtor elems -makeApply :: EgisonExpr -> [EgisonExpr] -> EgisonExpr -makeApply (InductiveDataExpr x []) xs = InductiveDataExpr x xs -makeApply func xs = ApplyExpr func (TupleExpr xs) - -makeApply' :: String -> [EgisonExpr] -> EgisonExpr -makeApply' func xs = ApplyExpr (stringToVarExpr func) (TupleExpr xs) - indentGuardEQ :: Pos -> Parser Pos indentGuardEQ pos = L.indentGuard sc EQ pos @@ -942,12 +898,12 @@ indented :: Parser Pos indented = indentGuardGT pos1 -infixToOperator :: (Infix -> Parser (a -> a -> a)) -> Infix -> Operator Parser a +infixToOperator :: (Op -> Parser (a -> a -> a)) -> Op -> Operator Parser a infixToOperator opToParser op = case assoc op of - LeftAssoc -> InfixL (opToParser op) - RightAssoc -> InfixR (opToParser op) - NonAssoc -> InfixN (opToParser op) + E.InfixL -> InfixL (opToParser op) + E.InfixR -> InfixR (opToParser op) + E.InfixN -> InfixN (opToParser op) tupleOrSome :: Parser a -> Parser [a] tupleOrSome p = parens (sepBy p comma) <|> some p 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,13 +1,12 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-all #-} -- Since we will soon deprecate this parser +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-all #-} -- Since we will soon deprecate this parser {- | Module : Language.Egison.Parser.SExpr Licence : MIT -This module provides Egison parser. +This module implements the parser for the old S-expression syntax. -} module Language.Egison.Parser.SExpr @@ -36,27 +35,26 @@ import qualified Text.Parsec.Token as P import Language.Egison.AST -import Language.Egison.Data -parseTopExprs :: String -> Either EgisonError [EgisonTopExpr] +parseTopExprs :: String -> Either String [TopExpr] parseTopExprs = doParse $ do ret <- whiteSpace >> endBy topExpr whiteSpace eof return ret -parseTopExpr :: String -> Either EgisonError EgisonTopExpr +parseTopExpr :: String -> Either String TopExpr parseTopExpr = doParse $ do ret <- whiteSpace >> topExpr whiteSpace >> eof return ret -parseExprs :: String -> Either EgisonError [EgisonExpr] +parseExprs :: String -> Either String [Expr] parseExprs = doParse $ do ret <- whiteSpace >> endBy expr whiteSpace eof return ret -parseExpr :: String -> Either EgisonError EgisonExpr +parseExpr :: String -> Either String Expr parseExpr = doParse $ do ret <- whiteSpace >> expr whiteSpace >> eof @@ -66,11 +64,8 @@ -- Parser -- -doParse :: Parser a -> String -> Either EgisonError a -doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input - where - fromParsecError :: ParseError -> EgisonError - fromParsecError = Parser . show +doParse :: Parser a -> String -> Either String a +doParse p input = either (throwError . show) return $ parse p "egison" input doParse' :: Parser a -> String -> a doParse' p input = case doParse p input of @@ -79,41 +74,36 @@ -- -- Expressions -- -topExpr :: Parser EgisonTopExpr +topExpr :: Parser TopExpr topExpr = try (Test <$> expr) <|> try defineExpr - <|> try (parens (redefineExpr - <|> testExpr + <|> try (parens (testExpr <|> executeExpr <|> loadFileExpr <|> loadExpr)) "top-level expression" -defineExpr :: Parser EgisonTopExpr -defineExpr = try (parens (keywordDefine >> Define <$> (char '$' >> identVar) <*> expr)) - <|> try (parens (keywordDefine >> DefineWithIndices <$> (char '$' >> identVarWithIndices) <*> expr)) - -redefineExpr :: Parser EgisonTopExpr -redefineExpr = (keywordRedefine <|> keywordSet) >> Redefine <$> (char '$' >> identVar) <*> expr +defineExpr :: Parser TopExpr +defineExpr = parens (keywordDefine >> Define <$> (char '$' >> identVarWithIndices) <*> expr) -testExpr :: Parser EgisonTopExpr +testExpr :: Parser TopExpr testExpr = keywordTest >> Test <$> expr -executeExpr :: Parser EgisonTopExpr +executeExpr :: Parser TopExpr executeExpr = keywordExecute >> Execute <$> expr -loadFileExpr :: Parser EgisonTopExpr +loadFileExpr :: Parser TopExpr loadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral -loadExpr :: Parser EgisonTopExpr +loadExpr :: Parser TopExpr loadExpr = keywordLoad >> Load <$> stringLiteral -expr :: Parser EgisonExpr +expr :: Parser Expr expr = P.lexeme lexer (do expr0 <- expr' <|> quoteExpr expr1 <- option expr0 $ try (string "..." >> IndexedExpr False expr0 <$> parseindex) <|> IndexedExpr True expr0 <$> parseindex - option expr1 $ PowerExpr expr1 <$> try (char '^' >> expr')) - where parseindex :: Parser [Index EgisonExpr] + option expr1 $ (\x -> makeApply "**" [expr1, x]) <$> try (char '^' >> expr')) + where parseindex :: Parser [IndexExpr Expr] parseindex = many1 (try (MultiSubscript <$> (char '_' >> expr') <*> (string "..._" >> expr')) <|> try (MultiSuperscript <$> (char '~' >> expr') <*> (string "...~" >> expr')) <|> try (Subscript <$> (char '_' >> expr')) @@ -122,12 +112,12 @@ <|> try (Userscript <$> (char '|' >> expr'))) -quoteExpr :: Parser EgisonExpr +quoteExpr :: Parser Expr quoteExpr = char '\'' >> QuoteExpr <$> expr' -expr' :: Parser EgisonExpr +expr' :: Parser Expr expr' = try anonParamFuncExpr - <|> try constantExpr + <|> try (ConstantExpr <$> constantExpr) <|> try anonParamExpr <|> try freshVarExpr <|> try varExpr @@ -148,7 +138,6 @@ <|> letStarExpr <|> withSymbolsExpr <|> doExpr - <|> ioExpr <|> matchAllExpr <|> matchAllDFSExpr <|> matchExpr @@ -173,70 +162,95 @@ ) "expression" -varExpr :: Parser EgisonExpr -varExpr = VarExpr <$> identVarWithoutIndex +varExpr :: Parser Expr +varExpr = VarExpr <$> ident -freshVarExpr :: Parser EgisonExpr +freshVarExpr :: Parser Expr freshVarExpr = char '#' >> return FreshVarExpr -inductiveDataExpr :: Parser EgisonExpr -inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy expr whiteSpace +inductiveDataExpr :: Parser Expr +inductiveDataExpr = angles $ do + name <- upperName + args <- sepEndBy expr whiteSpace + return $ makeApply name args -tupleExpr :: Parser EgisonExpr +tupleExpr :: Parser Expr tupleExpr = brackets $ TupleExpr <$> sepEndBy expr whiteSpace -collectionExpr :: Parser EgisonExpr -collectionExpr = braces $ CollectionExpr <$> sepEndBy innerExpr whiteSpace +data InnerExpr + = ElementExpr Expr + | SubCollectionExpr Expr + +collectionExpr :: Parser Expr +collectionExpr = do + inners <- braces $ sepEndBy innerExpr whiteSpace + return $ f [] inners where innerExpr :: Parser InnerExpr innerExpr = (char '@' >> SubCollectionExpr <$> expr) <|> ElementExpr <$> expr -vectorExpr :: Parser EgisonExpr + isElementExpr :: InnerExpr -> Bool + isElementExpr ElementExpr{} = True + 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 [] (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)) + + +vectorExpr :: Parser Expr vectorExpr = between lp rp $ VectorExpr <$> sepEndBy expr whiteSpace where lp = P.lexeme lexer (string "[|") rp = string "|]" -hashExpr :: Parser EgisonExpr +hashExpr :: Parser Expr hashExpr = between lp rp $ HashExpr <$> sepEndBy pairExpr whiteSpace where lp = P.lexeme lexer (string "{|") rp = string "|}" - pairExpr :: Parser (EgisonExpr, EgisonExpr) + pairExpr :: Parser (Expr, Expr) pairExpr = brackets $ (,) <$> expr <*> expr -wedgeExpr :: Parser EgisonExpr +wedgeExpr :: Parser Expr wedgeExpr = do e <- char '!' >> expr case e of ApplyExpr e1 e2 -> return $ WedgeApplyExpr e1 e2 -functionWithArgExpr :: Parser EgisonExpr -functionWithArgExpr = keywordFunction >> FunctionExpr <$> between lp rp (sepEndBy expr whiteSpace) +functionWithArgExpr :: Parser Expr +functionWithArgExpr = keywordFunction >> FunctionExpr <$> between lp rp (sepEndBy ident whiteSpace) where lp = P.lexeme lexer (char '[') rp = char ']' -quoteSymbolExpr :: Parser EgisonExpr +quoteSymbolExpr :: Parser Expr quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr -matchAllExpr :: Parser EgisonExpr +matchAllExpr :: Parser Expr matchAllExpr = keywordMatchAll >> MatchAllExpr BFSMode <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses) -matchAllDFSExpr :: Parser EgisonExpr +matchAllDFSExpr :: Parser Expr matchAllDFSExpr = keywordMatchAllDFS >> MatchAllExpr DFSMode <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses) -matchExpr :: Parser EgisonExpr +matchExpr :: Parser Expr matchExpr = keywordMatch >> MatchExpr BFSMode <$> expr <*> expr <*> matchClauses -matchDFSExpr :: Parser EgisonExpr +matchDFSExpr :: Parser Expr matchDFSExpr = keywordMatchDFS >> MatchExpr DFSMode <$> expr <*> expr <*> matchClauses -matchAllLambdaExpr :: Parser EgisonExpr +matchAllLambdaExpr :: Parser Expr matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> (((:[]) <$> matchClause) <|> matchClauses) -matchLambdaExpr :: Parser EgisonExpr +matchLambdaExpr :: Parser Expr matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses matchClauses :: Parser [MatchClause] @@ -245,7 +259,7 @@ matchClause :: Parser MatchClause matchClause = brackets $ (,) <$> pattern <*> expr -matcherExpr :: Parser EgisonExpr +matcherExpr :: Parser Expr matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses ppMatchClauses :: Parser [PatternDef] @@ -254,10 +268,10 @@ ppMatchClause :: Parser PatternDef ppMatchClause = brackets $ (,,) <$> ppPattern <*> expr <*> pdMatchClauses -pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)] +pdMatchClauses :: Parser [(PrimitiveDataPattern, Expr)] pdMatchClauses = braces $ sepEndBy pdMatchClause whiteSpace -pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr) +pdMatchClause :: Parser (PrimitiveDataPattern, Expr) pdMatchClause = brackets $ (,) <$> pdPattern <*> expr ppPattern :: Parser PrimitivePatPattern @@ -297,100 +311,106 @@ <|> PDConstantPat <$> constantExpr "primitive-data-pattern" -ifExpr :: Parser EgisonExpr +ifExpr :: Parser Expr ifExpr = keywordIf >> IfExpr <$> expr <*> expr <*> expr -lambdaExpr :: Parser EgisonExpr +lambdaExpr :: Parser Expr lambdaExpr = keywordLambda >> LambdaExpr <$> argNames <*> expr -memoizedLambdaExpr :: Parser EgisonExpr +memoizedLambdaExpr :: Parser Expr memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <*> expr -memoizeFrame :: Parser [(EgisonExpr, EgisonExpr, EgisonExpr)] +memoizeFrame :: Parser [(Expr, Expr, Expr)] memoizeFrame = braces $ sepEndBy memoizeBinding whiteSpace -memoizeBinding :: Parser (EgisonExpr, EgisonExpr, EgisonExpr) +memoizeBinding :: Parser (Expr, Expr, Expr) memoizeBinding = brackets $ (,,) <$> expr <*> expr <*> expr -cambdaExpr :: Parser EgisonExpr +cambdaExpr :: Parser Expr cambdaExpr = keywordCambda >> char '$' >> CambdaExpr <$> ident <*> expr -patternFunctionExpr :: Parser EgisonExpr +patternFunctionExpr :: Parser Expr patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern -letRecExpr :: Parser EgisonExpr +letRecExpr :: Parser Expr letRecExpr = keywordLetRec >> LetRecExpr <$> bindings <*> expr -letExpr :: Parser EgisonExpr -letExpr = keywordLet >> LetExpr <$> bindings <*> expr +letExpr :: Parser Expr +letExpr = keywordLet >> LetRecExpr <$> bindings <*> expr -letStarExpr :: Parser EgisonExpr -letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <*> expr +letStarExpr :: Parser Expr +letStarExpr = keywordLetStar >> LetRecExpr <$> bindings <*> expr -withSymbolsExpr :: Parser EgisonExpr +withSymbolsExpr :: Parser Expr withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident whiteSpace) <*> expr -doExpr :: Parser EgisonExpr -doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (stringToVarExpr "return") (TupleExpr [])) expr +doExpr :: Parser Expr +doExpr = keywordDo >> DoExpr <$> statements <*> option (makeApply "return" []) expr statements :: Parser [BindingExpr] statements = braces $ sepEndBy statement whiteSpace statement :: Parser BindingExpr statement = try binding - <|> try (brackets (([],) <$> expr)) - <|> (([],) <$> expr) + <|> try (brackets (Bind (PDTuplePat []) <$> expr)) + <|> (Bind (PDTuplePat []) <$> expr) +bindings' :: Parser [(PrimitiveDataPattern, Expr)] +bindings' = braces $ sepEndBy binding' whiteSpace + +binding' :: Parser (PrimitiveDataPattern, Expr) +binding' = brackets $ (,) <$> varNames' <*> expr + bindings :: Parser [BindingExpr] bindings = braces $ sepEndBy binding whiteSpace binding :: Parser BindingExpr -binding = brackets $ (,) <$> varNames' <*> expr +binding = brackets $ Bind <$> varNames' <*> expr varNames :: Parser [String] varNames = return <$> (char '$' >> ident) <|> brackets (sepEndBy (char '$' >> ident) whiteSpace) -varNames' :: Parser [Var] -varNames' = return <$> (char '$' >> identVar) - <|> brackets (sepEndBy (char '$' >> identVar) whiteSpace) +varNames' :: Parser PrimitiveDataPattern +varNames' = PDPatVar <$> (char '$' >> ident) + <|> PDTuplePat <$> brackets (sepEndBy (PDPatVar <$> (char '$' >> ident)) whiteSpace) -argNames :: Parser [Arg] +argNames :: Parser [Arg ArgPattern] argNames = return <$> argName <|> brackets (sepEndBy argName whiteSpace) -argName :: Parser Arg -argName = try (ScalarArg <$> (char '$' >> ident)) - <|> try (InvertedScalarArg <$> (string "*$" >> ident)) - <|> try (TensorArg <$> (char '%' >> ident)) +argName :: Parser (Arg ArgPattern) +argName = try (ScalarArg <$> (char '$' >> argPattern)) + <|> try (InvertedScalarArg <$> (string "*$" >> argPattern)) + <|> try (TensorArg <$> (char '%' >> argPattern)) -ioExpr :: Parser EgisonExpr -ioExpr = keywordIo >> IoExpr <$> expr +argPattern :: Parser ArgPattern +argPattern = APPatVar <$> ident -seqExpr :: Parser EgisonExpr +seqExpr :: Parser Expr seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr -cApplyExpr :: Parser EgisonExpr +cApplyExpr :: Parser Expr cApplyExpr = keywordCApply >> CApplyExpr <$> expr <*> expr -applyExpr :: Parser EgisonExpr +applyExpr :: Parser Expr applyExpr = do func <- expr args <- sepEndBy arg whiteSpace let vars = lefts args case vars of - [] -> return . ApplyExpr func . TupleExpr $ rights args + [] -> return $ ApplyExpr func (rights args) _ | all null vars -> let n = toInteger (length vars) args' = f args 1 - in return $ AnonParamFuncExpr n $ ApplyExpr func (TupleExpr args') + in return $ AnonParamFuncExpr n $ ApplyExpr func args' | all (not . null) vars -> let ns = Set.fromList $ map read vars n = Set.size ns in if Set.findMin ns == 1 && Set.findMax ns == n then let args' = map g args - in return $ AnonParamFuncExpr (toInteger n) $ ApplyExpr func (TupleExpr args') + in return $ AnonParamFuncExpr (toInteger n) $ ApplyExpr func args' else fail "invalid anonymous parameter function" | otherwise -> fail "invalid anonymous parameter function" where @@ -403,59 +423,58 @@ g (Left arg) = AnonParamExpr (read arg) g (Right expr) = expr -anonParamFuncExpr :: Parser EgisonExpr +anonParamFuncExpr :: Parser Expr anonParamFuncExpr = (AnonParamFuncExpr . read <$> index) <*> (char '#' >> expr) where index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit -anonParamExpr :: Parser EgisonExpr +anonParamExpr :: Parser Expr anonParamExpr = char '%' >> AnonParamExpr <$> integerLiteral -algebraicDataMatcherExpr :: Parser EgisonExpr +algebraicDataMatcherExpr :: Parser Expr algebraicDataMatcherExpr = keywordAlgebraicDataMatcher >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 inductivePat' whiteSpace) where - inductivePat' :: Parser (String, [EgisonExpr]) + inductivePat' :: Parser (String, [Expr]) inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace -generateTensorExpr :: Parser EgisonExpr +generateTensorExpr :: Parser Expr generateTensorExpr = keywordGenerateTensor >> GenerateTensorExpr <$> expr <*> expr -tensorExpr :: Parser EgisonExpr +tensorExpr :: Parser Expr tensorExpr = keywordTensor >> TensorExpr <$> expr <*> expr -tensorContractExpr :: Parser EgisonExpr +tensorContractExpr :: Parser Expr tensorContractExpr = keywordTensorContract >> TensorContractExpr <$> expr ---tensorContractExpr = keywordTensorContract >> TensorContractExpr <$> expr <*> expr -tensorMapExpr :: Parser EgisonExpr +tensorMapExpr :: Parser Expr tensorMapExpr = keywordTensorMap >> TensorMapExpr <$> expr <*> expr -tensorMap2Expr :: Parser EgisonExpr +tensorMap2Expr :: Parser Expr tensorMap2Expr = keywordTensorMap2 >> TensorMap2Expr <$> expr <*> expr <*> expr -transposeExpr :: Parser EgisonExpr +transposeExpr :: Parser Expr transposeExpr = keywordTranspose >> TransposeExpr <$> expr <*> expr -subrefsExpr :: Parser EgisonExpr +subrefsExpr :: Parser Expr subrefsExpr = (keywordSubrefs >> SubrefsExpr False <$> expr <*> expr) <|> (keywordSubrefsNew >> SubrefsExpr True <$> expr <*> expr) -suprefsExpr :: Parser EgisonExpr +suprefsExpr :: Parser Expr suprefsExpr = (keywordSuprefs >> SuprefsExpr False <$> expr <*> expr) <|> (keywordSuprefsNew >> SuprefsExpr True <$> expr <*> expr) -userrefsExpr :: Parser EgisonExpr +userrefsExpr :: Parser Expr userrefsExpr = (keywordUserrefs >> UserrefsExpr False <$> expr <*> expr) <|> (keywordUserrefsNew >> UserrefsExpr True <$> expr <*> expr) -- Patterns -pattern :: Parser EgisonPattern +pattern :: Parser Pattern pattern = P.lexeme lexer (do pattern <- pattern' option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> expr')) -pattern' :: Parser EgisonPattern +pattern' :: Parser Pattern pattern' = wildCard <|> contPat <|> patVar @@ -474,127 +493,104 @@ <|> orPat <|> loopPat <|> letPat - <|> try divPat - <|> try plusPat - <|> try multPat <|> try dApplyPat <|> try pApplyPat ) -pattern'' :: Parser EgisonPattern +pattern'' :: Parser Pattern pattern'' = wildCard <|> patVar <|> valuePat -wildCard :: Parser EgisonPattern +wildCard :: Parser Pattern wildCard = reservedOp "_" >> pure WildCard -patVar :: Parser EgisonPattern -patVar = char '$' >> PatVar <$> identVarWithoutIndex +patVar :: Parser Pattern +patVar = char '$' >> PatVar <$> ident -varPat :: Parser EgisonPattern +varPat :: Parser Pattern varPat = VarPat <$> ident -valuePat :: Parser EgisonPattern +valuePat :: Parser Pattern valuePat = char ',' >> ValuePat <$> expr -predPat :: Parser EgisonPattern +predPat :: Parser Pattern predPat = char '?' >> PredPat <$> expr -letPat :: Parser EgisonPattern +letPat :: Parser Pattern letPat = keywordLet >> LetPat <$> bindings <*> pattern -notPat :: Parser EgisonPattern +notPat :: Parser Pattern notPat = char '!' >> NotPat <$> pattern -notPat' :: Parser EgisonPattern +notPat' :: Parser Pattern notPat' = keywordNot >> NotPat <$> pattern -tuplePat :: Parser EgisonPattern +tuplePat :: Parser Pattern tuplePat = brackets $ TuplePat <$> sepEndBy pattern whiteSpace -inductivePat :: Parser EgisonPattern +inductivePat :: Parser Pattern inductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy pattern whiteSpace -contPat :: Parser EgisonPattern +contPat :: Parser Pattern contPat = keywordCont >> pure ContPat -andPat :: Parser EgisonPattern -andPat = (reservedOp "&" <|> keywordAnd) >> AndPat <$> sepEndBy pattern whiteSpace +andPat :: Parser Pattern +andPat = do + pats <- (reservedOp "&" <|> keywordAnd) >> sepEndBy pattern whiteSpace + case pats of + [] -> return WildCard + _ -> return $ foldr1 AndPat pats -orPat :: Parser EgisonPattern -orPat = (reservedOp "|" <|> keywordOr) >> OrPat <$> sepEndBy pattern whiteSpace +orPat :: Parser Pattern +orPat = do + pats <- (reservedOp "|" <|> keywordOr) >> sepEndBy pattern whiteSpace + case pats of + [] -> return (NotPat WildCard) + _ -> return $ foldr1 OrPat pats -pApplyPat :: Parser EgisonPattern +pApplyPat :: Parser Pattern pApplyPat = PApplyPat <$> expr <*> sepEndBy pattern whiteSpace -dApplyPat :: Parser EgisonPattern +dApplyPat :: Parser Pattern dApplyPat = DApplyPat <$> pattern'' <*> sepEndBy pattern whiteSpace -loopPat :: Parser EgisonPattern -loopPat = keywordLoop >> char '$' >> LoopPat <$> identVarWithoutIndex <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern +loopPat :: Parser Pattern +loopPat = keywordLoop >> char '$' >> LoopPat <$> ident <*> loopRange <*> pattern <*> option (NotPat WildCard) pattern loopRange :: Parser LoopRange loopRange = brackets (try (LoopRange <$> expr <*> expr <*> option WildCard pattern) <|> (do s <- expr ep <- option WildCard pattern - return (LoopRange s (ApplyExpr (stringToVarExpr "from") (ApplyExpr (stringToVarExpr "-'") (TupleExpr [s, IntegerExpr 1]))) ep))) + return (LoopRange s (makeApply "from" [makeApply "-'" [s, ConstantExpr (IntegerExpr 1)]]) ep))) -seqNilPat :: Parser EgisonPattern +seqNilPat :: Parser Pattern seqNilPat = braces $ pure SeqNilPat -seqConsPat :: Parser EgisonPattern +seqConsPat :: Parser Pattern seqConsPat = braces $ SeqConsPat <$> pattern <*> (char '@' >> pattern) -seqPat :: Parser EgisonPattern +seqPat :: Parser Pattern seqPat = braces $ do pats <- sepEndBy pattern whiteSpace tailPat <- option SeqNilPat (char '@' >> pattern) return $ foldr SeqConsPat tailPat pats -laterPatVar :: Parser EgisonPattern +laterPatVar :: Parser Pattern laterPatVar = char '#' >> pure LaterPatVar -divPat :: Parser EgisonPattern -divPat = reservedOp "/" >> DivPat <$> pattern <*> pattern - -plusPat :: Parser EgisonPattern -plusPat = reservedOp "+" >> PlusPat <$> sepEndBy pattern whiteSpace - -multPat :: Parser EgisonPattern -multPat = reservedOp "*" >> MultPat <$> sepEndBy powerPat whiteSpace - -powerPat :: Parser EgisonPattern -powerPat = try (PowerPat <$> pattern <* char '^' <*> pattern) - <|> pattern - -- Constants -constantExpr :: Parser EgisonExpr -constantExpr = stringExpr - <|> boolExpr - <|> try charExpr - <|> try floatExpr - <|> try integerExpr +constantExpr :: Parser ConstantExpr +constantExpr = StringExpr . T.pack <$> stringLiteral + <|> BoolExpr <$> boolLiteral + <|> try (CharExpr <$> oneChar) + <|> try (FloatExpr <$> positiveFloatLiteral) + <|> try (IntegerExpr <$> integerLiteral) <|> (keywordSomething $> SomethingExpr) <|> (keywordUndefined $> UndefinedExpr) "constant" -charExpr :: Parser EgisonExpr -charExpr = CharExpr <$> oneChar - -stringExpr :: Parser EgisonExpr -stringExpr = StringExpr . T.pack <$> stringLiteral - -boolExpr :: Parser EgisonExpr -boolExpr = BoolExpr <$> boolLiteral - -floatExpr :: Parser EgisonExpr -floatExpr = FloatExpr <$> positiveFloatLiteral - -integerExpr :: Parser EgisonExpr -integerExpr = IntegerExpr <$> integerLiteral - positiveFloatLiteral :: Parser Double positiveFloatLiteral = do n <- integerLiteral @@ -634,7 +630,6 @@ reservedKeywords :: [String] reservedKeywords = [ "define" - , "redefine" , "set!" , "test" , "execute" @@ -664,7 +659,6 @@ , "match-lambda" , "matcher" , "do" - , "io" , "algebraic-data-matcher" , "generate-tensor" , "tensor" @@ -704,7 +698,6 @@ reservedOp = P.reservedOp lexer keywordDefine = reserved "define" -keywordRedefine = reserved "redefine" keywordSet = reserved "set!" keywordTest = reserved "test" keywordExecute = reserved "execute" @@ -794,26 +787,17 @@ ident :: Parser String ident = toCamelCase <$> P.identifier lexer -identVar :: Parser Var -identVar = P.lexeme lexer (do - name <- ident - is <- many indexType - return $ Var (splitOn "." name) is) - -identVarWithoutIndex :: Parser Var -identVarWithoutIndex = stringToVar <$> ident - identVarWithIndices :: Parser VarWithIndices identVarWithIndices = P.lexeme lexer (do name <- ident is <- many indexForVar - return $ VarWithIndices (splitOn "." name) is) + return $ VarWithIndices name is) -indexForVar :: Parser (Index String) -indexForVar = try (char '~' >> Superscript <$> ident) - <|> try (char '_' >> Subscript <$> ident) +indexForVar :: Parser VarIndex +indexForVar = try (char '~' >> VSuperscript <$> ident) + <|> try (char '_' >> VSubscript <$> ident) -indexType :: Parser (Index ()) +indexType :: Parser (IndexExpr ()) indexType = try (char '~' >> return (Superscript ())) <|> try (char '_' >> return (Subscript ())) 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,5 +1,9 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} {- | Module : Language.Egison.PrettyPrint @@ -10,47 +14,49 @@ module Language.Egison.Pretty ( prettyTopExprs - , PrettyS(..) , prettyStr - , prettyStr' , showTSV ) where import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HashMap import Data.List (intercalate) import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String (renderString) -import qualified Data.Vector as V +import Text.Show.Unicode (ushow) import Language.Egison.AST -import Language.Egison.MathExpr hiding (Printable(..)) import Language.Egison.Data +import Language.Egison.IExpr -- -- Pretty printing for Non-S syntax -- -prettyTopExprs :: [EgisonTopExpr] -> Doc [EgisonTopExpr] +prettyTopExprs :: [TopExpr] -> Doc [TopExpr] prettyTopExprs exprs = vsep $ punctuate line (map pretty exprs) -instance Pretty EgisonTopExpr where +instance Pretty TopExpr where pretty (Define x (LambdaExpr args body)) = - hsep (pretty x : map pretty args) <+> indentBlock (pretty ":=") [pretty body] + hsep (pretty "def" : pretty x : map pretty' args) <+> indentBlock (pretty ":=") [pretty body] pretty (Define x expr) = - pretty x <+> indentBlock (pretty ":=") [pretty expr] + pretty "def" <+> pretty x <+> indentBlock (pretty ":=") [pretty expr] pretty (Test expr) = pretty expr pretty (LoadFile file) = pretty "loadFile" <+> pretty (show file) pretty (Load lib) = pretty "load" <+> pretty (show lib) pretty _ = error "Unsupported topexpr" -instance Pretty EgisonExpr where - -- Use |viaShow| to correctly handle escaped characters +instance Pretty ConstantExpr where pretty (CharExpr x) = viaShow x - pretty (StringExpr x) = viaShow x + pretty (StringExpr x) = pretty (ushow x) pretty (BoolExpr x) = pretty x pretty (IntegerExpr x) = pretty x pretty (FloatExpr x) = pretty x + pretty SomethingExpr = pretty "something" + pretty UndefinedExpr = pretty "undefined" + +instance Pretty Expr where + pretty (ConstantExpr c) = pretty c + -- Use |viaShow| to correctly handle escaped characters pretty (VarExpr x) = pretty x pretty FreshVarExpr = pretty "#" pretty (IndexedExpr True e indices) = pretty' e <> cat (map pretty indices) @@ -65,8 +71,6 @@ applyLike [pretty "userRefs" <> (if b then pretty "!" else emptyDoc), pretty' e1, pretty' e2] - pretty (InductiveDataExpr c xs) = nest 2 (sep (pretty c : map pretty' xs)) - pretty (TupleExpr xs) = tupled (map pretty xs) pretty (CollectionExpr xs) | length xs < 20 = list (map pretty xs) @@ -89,8 +93,6 @@ [pretty "then" <+> pretty y, pretty "else" <+> pretty z] pretty (LetRecExpr bindings body) = hang 1 (pretty "let" <+> align (vsep (map pretty bindings)) <> hardline <> pretty "in" <+> align (pretty body)) - pretty (LetExpr _ _) = error "unreachable" - pretty (LetStarExpr _ _) = error "unreachable" pretty (WithSymbolsExpr xs e) = indentBlock (pretty "withSymbols" <+> list (map pretty xs)) [pretty e] @@ -125,18 +127,18 @@ pretty (QuoteExpr e) = squote <> pretty' e pretty (QuoteSymbolExpr e) = pretty '`' <> pretty' e - pretty (PrefixExpr op x@(IntegerExpr _)) = pretty op <> pretty x + pretty (PrefixExpr op x@(ConstantExpr (IntegerExpr _))) = pretty op <> pretty x pretty (PrefixExpr op x) | isAtomOrApp x = pretty op <+> pretty x | otherwise = pretty op <+> parens (pretty x) -- (x1 op' x2) op y pretty (InfixExpr op x@(InfixExpr op' _ _) y) = - if priority op > priority op' || priority op == priority op' && assoc op == RightAssoc + if priority op > priority op' || priority op == priority op' && assoc op == InfixR then parens (pretty x) <+> pretty op <> infixRight (pretty'' y) else pretty x <+> pretty op <> infixRight (pretty'' y) -- x op (y1 op' y2) pretty (InfixExpr op x y@(InfixExpr op' _ _)) = - if priority op > priority op' || priority op == priority op' && assoc op == LeftAssoc + if priority op > priority op' || priority op == priority op' && assoc op == InfixL then pretty'' x <+> pretty op <> infixRight (parens (pretty y)) else pretty'' x <+> pretty op <> infixRight (pretty y) pretty (InfixExpr op x y) = @@ -146,15 +148,12 @@ pretty (SectionExpr op Nothing (Just x)) = parens (pretty op <+> pretty x) pretty (DoExpr [] y) = pretty "do" <+> pretty y - pretty (DoExpr xs (ApplyExpr (VarExpr (Var ["return"] [])) (TupleExpr []))) = + pretty (DoExpr xs (ApplyExpr (VarExpr "return") [])) = pretty "do" <+> align (hsepHard (map prettyDoBinds xs)) pretty (DoExpr xs y) = pretty "do" <+> align (hsepHard (map prettyDoBinds xs ++ [pretty y])) - pretty (IoExpr x) = pretty "io" <+> pretty x pretty (SeqExpr e1 e2) = applyLike [pretty "seq", pretty' e1, pretty' e2] - pretty (ApplyExpr x y@(TupleExpr [])) = applyLike (map pretty' [x, y]) - pretty (ApplyExpr x (TupleExpr ys)) = applyLike (map pretty' (x : ys)) - pretty (ApplyExpr x y) = applyLike [pretty' x, pretty' y] + pretty (ApplyExpr x ys) = applyLike (map pretty' (x : ys)) pretty (CApplyExpr e1 e2) = applyLike [pretty "capply", pretty' e1, pretty' e2] pretty (AnonParamFuncExpr n e) = pretty n <> pretty '#' <> pretty' e pretty (AnonParamExpr n) = pretty '%' <> pretty n @@ -175,64 +174,57 @@ pretty (FunctionExpr xs) = pretty "function" <+> tupled (map pretty xs) - pretty SomethingExpr = pretty "something" - pretty UndefinedExpr = pretty "undefined" - - pretty _ = pretty "REPLACEME" + pretty p = pretty (show p) -instance Pretty Arg where - pretty (ScalarArg x) = pretty x - pretty (InvertedScalarArg x) = pretty "*" <> pretty x - pretty (TensorArg x) = pretty '%' <> pretty x +instance (Pretty a, Complex a) => Pretty (Arg a) where + pretty (ScalarArg x) = pretty "$" <> pretty' x + pretty (InvertedScalarArg x) = pretty "*$" <> pretty' x + pretty (TensorArg x) = pretty x -instance Pretty Var where - pretty (Var xs is) = - concatWith (surround dot) (map pretty xs) <> hcat (map pretty is) +instance Pretty ArgPattern where + pretty APWildCard = pretty "_" + pretty (APPatVar x) = pretty x + pretty (APInductivePat x args) = applyLike (pretty x : map pretty' args) + pretty (APTuplePat args) = tupled (map pretty args) + pretty APEmptyPat = pretty "[]" + pretty (APConsPat arg1 arg2) = pretty'' arg1 <+> pretty "::" <+> pretty'' arg2 + pretty (APSnocPat arg1 arg2) = applyLike [pretty "snoc", pretty' arg1, pretty' arg2] instance Pretty VarWithIndices where - pretty (VarWithIndices xs is) = - concatWith (surround dot) (map pretty xs) <> hcat (map pretty is) + pretty (VarWithIndices xs is) = pretty xs <> hcat (map pretty is) -instance Pretty InnerExpr where - pretty (ElementExpr x) = pretty x - pretty (SubCollectionExpr _) = error "Not supported" +instance Pretty VarIndex where + 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 ']' -instance {-# OVERLAPPING #-} Pretty BindingExpr where - pretty ([var], LambdaExpr args body) = - hsep (pretty var : map pretty args) <+> indentBlock (pretty ":=") [pretty body] - pretty ([var], expr) = pretty var <+> pretty ":=" <+> align (pretty expr) - pretty (vars, expr) = tupled (map pretty vars) <+> pretty ":=" <+> align (pretty expr) +instance Pretty BindingExpr where + pretty (Bind (PDPatVar f) (LambdaExpr args body)) = + hsep (pretty f : map pretty' args) <+> indentBlock (pretty ":=") [pretty body] + pretty (Bind pat expr) = pretty pat <+> pretty ":=" <+> align (pretty expr) + pretty (BindWithIndices var expr) = pretty var <+> pretty ":=" <+> align (pretty expr) instance {-# OVERLAPPING #-} Pretty MatchClause where pretty (pat, expr) = pipe <+> align (pretty pat) <+> indentBlock (pretty "->") [pretty expr] -instance {-# OVERLAPPING #-} Pretty (Index ()) where -- Used for 'Var' - pretty Subscript{} = pretty '_' - pretty Superscript{} = pretty '~' - pretty SupSubscript{} = pretty "~_" - pretty DFscript{} = pretty "" - pretty Userscript{} = pretty '|' - pretty _ = undefined - -instance {-# OVERLAPPING #-} Pretty (Index String) where -- for 'VarWithIndices' +instance {-# OVERLAPPING #-} Pretty (IndexExpr String) where -- for 'VarWithIndices' pretty (Superscript s) = pretty ("~" ++ s) pretty (Subscript s) = pretty ("_" ++ s) pretty (SupSubscript s) = pretty ("~_" ++ s) - pretty (DFscript _ _) = pretty "" pretty (Userscript i) = pretty ("|" ++ show i) pretty _ = undefined -instance (Pretty a, Complex a) => Pretty (Index a) where +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 (MultiSuperscript i j) = pretty '~' <> pretty' i <> pretty "...~" <> pretty' j - pretty (DFscript _ _) = undefined pretty (Userscript i) = pretty '|' <> pretty' i -instance Pretty EgisonPattern where +instance Pretty Pattern where pretty WildCard = pretty "_" pretty (PatVar x) = pretty "$" <> pretty x pretty (ValuePat v) = pretty "#" <> pretty' v @@ -243,19 +235,19 @@ pretty "let" <+> align (vsep (map pretty binds)) <+> pretty "in" <+> pretty pat -- (p11 op' p12) op p2 pretty (InfixPat op p1@(InfixPat op' _ _) p2) = - if priority op > priority op' || priority op == priority op' && assoc op == RightAssoc + if priority op > priority op' || priority op == priority op' && assoc op == InfixR then parens (pretty p1) <+> pretty (repr op) <+> pretty'' p2 else pretty p1 <+> pretty (repr op) <+> pretty'' p2 -- p1 op (p21 op' p22) pretty (InfixPat op p1 p2@(InfixPat op' _ _)) = - if priority op > priority op' || priority op == priority op' && assoc op == LeftAssoc + if priority op > priority op' || priority op == priority op' && assoc op == InfixL then pretty'' p1 <+> pretty (repr op) <+> parens (pretty p2) else pretty'' p1 <+> pretty (repr op) <+> pretty p2 pretty (InfixPat op p1 p2) = pretty'' p1 <+> pretty (repr op) <+> pretty'' p2 pretty (NotPat pat) = pretty "!" <> pretty' pat pretty (TuplePat pats) = tupled $ map pretty pats pretty (InductivePat "nil" []) = pretty "[]" - pretty (InductivePat "cons" [p, InductivePat "nil" []]) = pretty "[" <> pretty p <> pretty "]" + pretty (InductivePat "::" [p, InductivePat "nil" []]) = pretty "[" <> pretty p <> pretty "]" pretty (InductivePat ctor xs) = hsep (pretty ctor : map pretty' xs) pretty (LoopPat i range p1 p2) = hang 2 (pretty "loop" <+> pretty '$' <> pretty i <+> pretty range <> @@ -272,11 +264,11 @@ f p1 p2 = [pretty p1, pretty p2] pretty LaterPatVar = pretty "@" pretty (DApplyPat p ps) = applyLike (map pretty' (p : ps)) - pretty _ = pretty "REPLACEME" + pretty e = pretty (show e) -instance Pretty LoopRange where - pretty (LoopRange from (ApplyExpr (VarExpr (Var ["from"] [])) - (InfixExpr (Infix { repr = "-'" }) _ (IntegerExpr 1))) pat) = +instance {-# OVERLAPPING #-} Pretty LoopRange where + pretty (LoopRange from (ApplyExpr (VarExpr "from") + [InfixExpr Op{ repr = "-'" } _ (ConstantExpr (IntegerExpr 1))]) pat) = tupled [pretty from, pretty pat] pretty (LoopRange from to pat) = tupled [pretty from, pretty to, pretty pat] @@ -289,7 +281,7 @@ instance Pretty PrimitiveDataPattern where pretty PDWildCard = pretty "_" - pretty (PDPatVar x) = pretty ('$' : x) + 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 "[]" @@ -297,21 +289,28 @@ pretty (PDSnocPat pdp1 pdp2) = applyLike [pretty "snoc", pretty' pdp1, pretty' pdp2] pretty (PDConstantPat expr) = pretty expr -instance Pretty Infix where +instance Pretty Op where pretty op | isWedge op = pretty ("!" ++ repr op) | otherwise = pretty (repr op) +instance Pretty IExpr where + pretty = undefined + +instance Complex IExpr where + isAtom = undefined + isAtomOrApp = undefined + isInfix = undefined + class Complex a where isAtom :: a -> Bool isAtomOrApp :: a -> Bool isInfix :: a -> Bool -instance Complex EgisonExpr where - isAtom (IntegerExpr i) | i < 0 = False - isAtom (InductiveDataExpr _ []) = True - isAtom (InductiveDataExpr _ _) = False +instance Complex Expr where + isAtom (ConstantExpr (IntegerExpr i)) | i < 0 = False isAtom PrefixExpr{} = False isAtom InfixExpr{} = False + isAtom (ApplyExpr _ []) = True isAtom ApplyExpr{} = False isAtom CApplyExpr{} = False isAtom LambdaExpr{} = False @@ -340,13 +339,30 @@ isAtom _ = True isAtomOrApp ApplyExpr{} = True - isAtomOrApp InductiveDataExpr{} = True isAtomOrApp e = isAtom e isInfix InfixExpr{} = True isInfix _ = False -instance Complex EgisonPattern where +instance Complex a => Complex (Arg a) where + isAtom (TensorArg x) = isAtom x + isAtom _ = True + + isAtomOrApp = isAtom + + isInfix _ = False + +instance Complex ArgPattern where + isAtom (APInductivePat _ []) = True + isAtom APInductivePat{} = False + isAtom APConsPat{} = False + isAtom APSnocPat{} = False + isAtom _ = True + + isAtomOrApp = isAtom + isInfix _ = False + +instance Complex Pattern where isAtom (LetPat _ _) = False isAtom (InductivePat _ []) = True isAtom (InductivePat _ _) = False @@ -356,12 +372,12 @@ isAtom (PApplyPat _ _) = False isAtom _ = True - isAtomOrApp PApplyPat{} = True + isAtomOrApp PApplyPat{} = True isAtomOrApp InductivePat{} = True - isAtomOrApp e = isAtom e + isAtomOrApp e = isAtom e - isInfix (InfixPat _ _ _) = True - isInfix _ = False + isInfix InfixPat{} = True + isInfix _ = False instance Complex PrimitiveDataPattern where isAtom (PDInductivePat _ []) = True @@ -374,8 +390,8 @@ isAtomOrApp PDSnocPat{} = True isAtomOrApp e = isAtom e - isInfix (PDConsPat _ _) = True - isInfix _ = False + isInfix PDConsPat{} = True + isInfix _ = False pretty' :: (Pretty a, Complex a) => a -> Doc ann pretty' x | isAtom x = pretty x @@ -387,10 +403,10 @@ -- Display "hoge" instead of "() := hoge" prettyDoBinds :: BindingExpr -> Doc ann -prettyDoBinds ([], expr) = pretty expr -prettyDoBinds (vs, expr) = pretty "let" <+> pretty (vs, expr) +prettyDoBinds (Bind (PDTuplePat []) expr) = pretty expr +prettyDoBinds bind = pretty "let" <+> pretty bind -prettyMatch :: EgisonExpr -> [MatchClause] -> Doc ann +prettyMatch :: Expr -> [MatchClause] -> Doc ann prettyMatch matcher clauses = pretty "as" <> group (flatAlt (hardline <> pretty matcher) (space <> pretty matcher) <+> pretty "with") <> hardline <> align (vsep (map pretty clauses)) @@ -431,113 +447,14 @@ infixRight :: Doc ann -> Doc ann infixRight p = group (flatAlt (hardline <> p) (space <> p)) +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 + -- -- Pretty printer for error messages -- prettyStr :: Pretty a => a -> String prettyStr = renderString . layoutPretty (LayoutOptions Unbounded) . pretty - -prettyStr' :: (Pretty a, Complex a) => a -> String -prettyStr' = renderString . layoutPretty (LayoutOptions Unbounded) . pretty' - --- --- Pretty printer for S-expression --- - -class PrettyS a where - prettyS :: a -> String - -instance PrettyS EgisonValue where - prettyS (Char c) = "c#" ++ [c] - prettyS (String str) = show str - prettyS (Bool True) = "#t" - prettyS (Bool False) = "#f" - prettyS (ScalarData mExpr) = prettyS mExpr - prettyS (TensorData (Tensor [_] xs js)) = "[| " ++ unwords (map prettyS (V.toList xs)) ++ " |]" ++ concatMap prettyS js - prettyS (TensorData (Tensor [0, 0] _ js)) = "[| [| |] |]" ++ concatMap prettyS js - prettyS (TensorData (Tensor [_, j] xs js)) = "[| " ++ f (fromIntegral j) (V.toList xs) ++ "|]" ++ concatMap prettyS js - where - f _ [] = "" - f j xs = "[| " ++ unwords (map prettyS (take j xs)) ++ " |] " ++ f j (drop j xs) - prettyS (TensorData (Tensor ns xs js)) = "(tensor {" ++ unwords (map show ns) ++ "} {" ++ unwords (map prettyS (V.toList xs)) ++ "} )" ++ concatMap prettyS js - prettyS (Float x) = show x - prettyS (InductiveData name vals) = "<" ++ name ++ concatMap ((' ':) . prettyS) vals ++ ">" - prettyS (Tuple vals) = "[" ++ unwords (map prettyS vals) ++ "]" - prettyS (Collection vals) = "{" ++ unwords (map prettyS (toList vals)) ++ "}" - prettyS (IntHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ prettyS val ++ "]") $ HashMap.toList hash) ++ "|}" - prettyS (CharHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ prettyS val ++ "]") $ HashMap.toList hash) ++ "|}" - prettyS (StrHash hash) = "{|" ++ unwords (map (\(key, val) -> "[" ++ show key ++ " " ++ prettyS val ++ "]") $ HashMap.toList hash) ++ "|}" - prettyS UserMatcher{} = "#" - prettyS (Func Nothing _ args _) = "(lambda [" ++ unwords (map ('$':) args) ++ "] ...)" - prettyS (Func (Just name) _ _ _) = prettyS name - prettyS (AnonParamFunc _ n _) = show n ++ "#(...)" - prettyS (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)" - prettyS (CFunc (Just name) _ _ _) = prettyS name - prettyS (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ unwords names ++ "] ...)" - prettyS (MemoizedFunc (Just name) _ _ _ _ _) = prettyS name - prettyS PatternFunc{} = "#" - prettyS (PrimitiveFunc name _) = "#" - prettyS (IOFunc _) = "#" - prettyS (Port _) = "#" - prettyS Something = "something" - prettyS Undefined = "undefined" - prettyS World = "#" - prettyS _ = "(not supported)" - -instance PrettyS Var where - prettyS = show - -instance PrettyS ScalarData where - prettyS (Div p1 (Plus [Term 1 []])) = prettyS p1 - prettyS (Div p1 p2) = "(/ " ++ prettyS p1 ++ " " ++ prettyS p2 ++ ")" - -instance PrettyS PolyExpr where - prettyS (Plus []) = "0" - prettyS (Plus [t]) = prettyS t - prettyS (Plus ts) = "(+ " ++ unwords (map prettyS ts) ++ ")" - -instance PrettyS TermExpr where - prettyS (Term a []) = show a - prettyS (Term 1 [x]) = showPoweredSymbol x - prettyS (Term 1 xs) = "(* " ++ unwords (map showPoweredSymbol xs) ++ ")" - prettyS (Term a xs) = "(* " ++ show a ++ " " ++ unwords (map showPoweredSymbol xs) ++ ")" - -showPoweredSymbol :: (SymbolExpr, Integer) -> String -showPoweredSymbol (x, 1) = prettyS x -showPoweredSymbol (x, n) = prettyS x ++ "^" ++ show n - -instance PrettyS SymbolExpr where - prettyS (Symbol _ (':':':':':':_) []) = "#" - prettyS (Symbol _ s []) = s - prettyS (Symbol _ s js) = s ++ concatMap prettyS js - prettyS (Apply fn mExprs) = "(" ++ prettyS fn ++ " " ++ unwords (map prettyS mExprs) ++ ")" - prettyS (Quote mExprs) = "'" ++ prettyS mExprs - prettyS (FunctionData name _ _ js) = show name ++ concatMap prettyS js - -showTSV :: EgisonValue -> String -showTSV (Tuple (val:vals)) = foldl (\r x -> r ++ "\t" ++ x) (prettyS val) (map prettyS vals) -showTSV (Collection vals) = intercalate "\t" (map prettyS (toList vals)) -showTSV val = prettyS val - -instance PrettyS a => PrettyS (Index a) where - prettyS (Subscript i) = "_" ++ prettyS i - prettyS (Superscript i) = "~" ++ prettyS i - prettyS (SupSubscript i) = "~_" ++ prettyS i - prettyS (MultiSubscript x y) = "_[" ++ prettyS x ++ "]..._[" ++ prettyS y ++ "]" - prettyS (MultiSuperscript x y) = "~[" ++ prettyS x ++ "]...~[" ++ prettyS y ++ "]" - prettyS (DFscript _ _) = "" - prettyS (Userscript i) = "|" ++ prettyS i - -instance {-# OVERLAPPING #-} PrettyS (Index EgisonValue) where - prettyS (Superscript i) = case i of - ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "~[" ++ prettyS i ++ "]" - _ -> "~" ++ prettyS i - prettyS (Subscript i) = case i of - ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "_[" ++ prettyS i ++ "]" - _ -> "_" ++ prettyS i - prettyS (SupSubscript i) = "~_" ++ prettyS i - prettyS (DFscript i j) = "_d" ++ show i ++ show j - prettyS (Userscript i) = case i of - ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "_[" ++ prettyS i ++ "]" - _ -> "|" ++ prettyS i 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} + {- | Module : Language.Egison.PrettyMath.AST Licence : MIT @@ -6,23 +8,29 @@ module Language.Egison.PrettyMath.AST ( MathExpr(..) , MathIndex(..) + , ToMathExpr(..) , isSub , parseExpr ) where +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 + data MathExpr = Atom String [MathIndex] | NegativeAtom String | Plus [MathExpr] | Multiply [MathExpr] + | Div MathExpr MathExpr | Power MathExpr MathExpr | Func MathExpr [MathExpr] | Tensor [MathExpr] [MathIndex] | Tuple [MathExpr] | Collection [MathExpr] - | Exp MathExpr | Quote MathExpr | Partial MathExpr [MathExpr] deriving (Eq, Show) @@ -36,6 +44,69 @@ isSub (Sub _) = True isSub _ = False + +class ToMathExpr a where + toMathExpr :: a -> MathExpr + +instance ToMathExpr E.EgisonValue where + 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) [] + +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) + +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) + +instance ToMathExpr E.PolyExpr where + toMathExpr (E.Plus []) = Atom "0" [] + toMathExpr (E.Plus [x]) = toMathExpr x + toMathExpr (E.Plus xs) = Plus (map toMathExpr xs) + +instance ToMathExpr E.TermExpr where + toMathExpr (E.Term n []) = toMathExpr n + toMathExpr (E.Term 1 [x]) = toMathExpr x + toMathExpr (E.Term 1 xs) = Multiply (map toMathExpr xs) + toMathExpr (E.Term n xs) = Multiply (toMathExpr n : map toMathExpr xs) + +instance ToMathExpr Integer where + toMathExpr n | n < 0 = NegativeAtom (show (-n)) + toMathExpr n = Atom (show n) [] + +instance {-# OVERLAPPING #-} ToMathExpr (E.SymbolExpr, Integer) where + toMathExpr (x, 1) = toMathExpr x + toMathExpr (x, n) = Power (toMathExpr x) (toMathExpr n) + +instance ToMathExpr E.SymbolExpr where + toMathExpr (E.Symbol _ (':':':':':':_) []) = Atom "#" [] + toMathExpr (E.Symbol _ s js) = 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 + + toMathExpr (E.Apply fn mExprs) = + case (toMathExpr fn, mExprs) of + (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 + +toMathIndex :: ToMathExpr a => E.Index a -> MathIndex +toMathIndex (E.Sub x) = Sub (toMathExpr x) +toMathIndex (E.Sup x) = Super (toMathExpr x) +toMathIndex _ = undefined -- TODO + -- -- Parser -- @@ -69,11 +140,14 @@ <|> Super <$> (char '~' >> parseAtom') parsePlus :: Parser MathExpr -parsePlus = string "(+" >> spaces >> Plus <$> parseList <* char ')' +parsePlus = try (string "(+") >> spaces >> Plus <$> parseList <* char ')' parseMultiply :: Parser MathExpr -parseMultiply = string "(*" >> spaces >> Multiply <$> parseList <* char ')' +parseMultiply = try (string "(*") >> spaces >> Multiply <$> parseList <* char ')' +parseDiv :: Parser MathExpr +parseDiv = try (string "(/") >> spaces >> Div <$> parseExpr <*> (spaces >> parseExpr) <* char ')' + parseFunction :: Parser MathExpr parseFunction = char '(' >> Func <$> parseAtom <* spaces <*> parseList <* char ')' @@ -86,9 +160,6 @@ parseCollection :: Parser MathExpr parseCollection = char '{' >> Collection <$> parseList <* char '}' -parseExp :: Parser MathExpr -parseExp = string "(exp" >> spaces >> Exp <$> parseExpr <* char ')' - parseQuote :: Parser MathExpr parseQuote = char '\'' >> Quote <$> parseExpr' @@ -97,9 +168,9 @@ <|> try parsePartial <|> parseAtom <|> parseQuote - <|> try parseExp - <|> try parsePlus - <|> try parseMultiply + <|> parsePlus + <|> parseMultiply + <|> parseDiv <|> try parseFunction <|> try parseTensor <|> try parseTuple 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 @@ -24,13 +24,14 @@ showMathExprForPlus (Multiply (NegativeAtom a:ys):xs) = " - " ++ showMathExpr (Multiply (Atom a []:ys)) ++ " " ++ showMathExprForPlus xs showMathExprForPlus (x:xs) = " + " ++ showMathExpr x ++ showMathExprForPlus xs showMathExpr (Multiply []) = "" -showMathExpr (Multiply [a]) = showMathExpr a -showMathExpr (Multiply (NegativeAtom "1":lvs)) = "-" ++ showMathExpr (Multiply lvs) -showMathExpr (Multiply lvs) = showMathExpr' (head lvs) ++ " " ++ showMathExpr (Multiply (tail lvs)) +showMathExpr (Multiply [x]) = showMathExpr x +showMathExpr (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExpr (Multiply xs) +showMathExpr (Multiply (x:xs)) = showMathExpr' x ++ " " ++ showMathExpr (Multiply xs) +showMathExpr (Div x y) = "frac{" ++ showMathExpr x ++ "}{" ++ showMathExpr y ++ "}" showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2 showMathExpr (Func (Atom "sqrt" []) [x]) = "sqrt " ++ showMathExpr x showMathExpr (Func (Atom "rt" []) [x, y]) = "root " ++ showMathExpr x ++ " " ++ showMathExpr y -showMathExpr (Func (Atom "/" []) [x, y]) = "frac{" ++ showMathExpr x ++ "}{" ++ showMathExpr y ++ "}" +showMathExpr (Func (Atom "exp" []) [x]) = "e^(" ++ showMathExpr x ++ ")" showMathExpr (Func f lvs) = showMathExpr f ++ "(" ++ showMathExprArg lvs ++ ")" showMathExpr (Tensor lvs mis) | null mis = "(" ++ showMathExprArg lvs ++ ")" @@ -39,7 +40,6 @@ | otherwise = "(" ++ showMathExprArg lvs ++ ")_(" ++ showMathExprIndices (filter isSub mis) ++ ")^(" ++ showMathExprIndices (filter (not . isSub) mis) ++ ")" showMathExpr (Tuple lvs) = "(" ++ showMathExprArg lvs ++ ")" showMathExpr (Collection lvs) = "{" ++ showMathExprArg lvs ++ "}" -showMathExpr (Exp x) = "e^(" ++ showMathExpr x ++ ")" showMathExpr' :: MathExpr -> String showMathExpr' (Plus lvs) = "(" ++ showMathExpr (Plus lvs) ++ ")" 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 @@ -41,15 +41,15 @@ showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs) showMathExpr (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExpr (Multiply xs) showMathExpr (Multiply (x:xs)) = showMathExpr' x ++ " " ++ showMathExpr (Multiply xs) +showMathExpr (Div x y) = "\\frac{" ++ showMathExpr x ++ "}{" ++ showMathExpr y ++ "}" showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2 showMathExpr (Func (Atom "sqrt" []) [x]) = "\\sqrt{" ++ showMathExpr x ++ "}" showMathExpr (Func (Atom "rt" []) [x, y]) = "\\sqrt[" ++ showMathExpr x ++ "]{" ++ showMathExpr y ++ "}" -showMathExpr (Func (Atom "/" []) [x, y]) = "\\frac{" ++ showMathExpr x ++ "}{" ++ showMathExpr y ++ "}" +showMathExpr (Func (Atom "exp" []) [x]) = "e^{" ++ showMathExpr x ++ "}" showMathExpr (Func f xs) = showMathExpr f ++ "(" ++ showMathExprArg xs ", " ++ ")" showMathExpr (Tensor xs mis) = "\\begin{pmatrix} " ++ showMathExprVectors xs ++ "\\end{pmatrix}" ++ showMathExprScript mis showMathExpr (Tuple xs) = "(" ++ showMathExprArg xs ", " ++ ")" showMathExpr (Collection xs) = "\\{" ++ showMathExprArg xs ", " ++ "\\}" -showMathExpr (Exp x) = "e^{" ++ showMathExpr x ++ "}" showMathExpr (Quote x) = "(" ++ showMathExpr x ++ ")" showMathExpr' :: MathExpr -> String 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 @@ -30,13 +30,14 @@ showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs) showMathExpr (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExpr (Multiply xs) showMathExpr (Multiply (x:xs)) = showMathExpr' x ++ " " ++ showMathExpr (Multiply xs) -showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2 -showMathExpr (Func (Atom "sqrt" []) [x]) = "Sqrt[" ++ showMathExpr x ++ "]" -showMathExpr (Func (Atom "rt" []) [x, y]) = "Surd[" ++ showMathExpr x ++ "," ++ showMathExpr y ++ "]" -showMathExpr (Func (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y +showMathExpr (Div x y) = addBracket x ++ "/" ++ addBracket y where addBracket x@(Atom _ []) = showMathExpr x addBracket x = "(" ++ showMathExpr x ++ ")" +showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2 +showMathExpr (Func (Atom "sqrt" []) [x]) = "Sqrt[" ++ showMathExpr x ++ "]" +showMathExpr (Func (Atom "rt" []) [x, y]) = "Surd[" ++ showMathExpr x ++ "," ++ showMathExpr y ++ "]" +showMathExpr (Func (Atom "exp" []) [x])= "e^(" ++ showMathExpr x ++ ")" showMathExpr (Func f xs) = showMathExpr f ++ "(" ++ showMathExprArg xs ++ ")" showMathExpr (Tensor lvs mis) | null mis = "{" ++ showMathExprArg lvs ++ "}" @@ -45,7 +46,6 @@ | otherwise = "{" ++ showMathExprArg lvs ++ "}_(" ++ showMathExprIndices (filter isSub mis) ++ ")^(" ++ showMathExprIndices (filter (not . isSub) mis) ++ ")" showMathExpr (Tuple xs) = "(" ++ showMathExprArg xs ++ ")" showMathExpr (Collection xs) = "{" ++ showMathExprArg xs ++ "}" -showMathExpr (Exp x) = "e^(" ++ showMathExpr x ++ ")" showMathExpr (Quote x) = "(" ++ showMathExpr x ++ ")" showMathExpr' :: MathExpr -> String 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 @@ -27,18 +27,18 @@ showMathExpr (Multiply (Atom "1" []:xs)) = showMathExpr (Multiply xs) showMathExpr (Multiply (NegativeAtom "1":xs)) = "-" ++ showMathExpr (Multiply xs) showMathExpr (Multiply (x:xs)) = showMathExpr' x ++ " * " ++ showMathExpr (Multiply xs) -showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2 -showMathExpr (Func (Atom "sqrt" []) [x]) = "sqrt(" ++ showMathExpr x ++ ")" -showMathExpr (Func (Atom "rt" []) [x, y]) = showMathExpr y ++ "^(1/" ++ showMathExpr x ++ ")" -showMathExpr (Func (Atom "/" []) [x, y]) = addBracket x ++ "/" ++ addBracket y +showMathExpr (Div x y) = addBracket x ++ "/" ++ addBracket y where addBracket x@(Atom _ []) = showMathExpr x addBracket x = "(" ++ showMathExpr x ++ ")" +showMathExpr (Power lv1 lv2) = showMathExpr lv1 ++ "^" ++ showMathExpr lv2 +showMathExpr (Func (Atom "sqrt" []) [x]) = "sqrt(" ++ showMathExpr x ++ ")" +showMathExpr (Func (Atom "rt" []) [x, y]) = showMathExpr y ++ "^(1/" ++ showMathExpr x ++ ")" +showMathExpr (Func (Atom "exp" []) [x]) = "exp(" ++ showMathExpr x ++ ")" showMathExpr (Func f xs) = showMathExpr f ++ "(" ++ showMathExprArg xs ++ ")" showMathExpr (Tensor _ _) = "undefined" showMathExpr (Tuple _) = "undefined" showMathExpr (Collection xs) = "[" ++ showMathExprArg xs ++ "]" -showMathExpr (Exp x) = "exp(" ++ showMathExpr x ++ ")" showMathExpr (Quote x) = "(" ++ showMathExpr x ++ ")" showMathExpr' :: MathExpr -> String 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,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} {- | Module : Language.Egison.Primitives @@ -10,660 +9,143 @@ -} module Language.Egison.Primitives - ( - primitiveEnv + ( primitiveEnv , primitiveEnvNoIO ) where import Control.Monad.Except -import Data.Foldable (toList) import Data.IORef -import Data.Ratio -import Text.Regex.TDFA ((=~~)) -import System.IO -import System.Process (readProcess) -import System.Random (getStdRandom, randomR) - import qualified Data.Sequence as Sq import qualified Data.Vector as V -import Data.Char (chr, ord) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T - {-- -- for 'egison-sqlite' import qualified Database.SQLite3 as SQLite --} -- for 'egison-sqlite' -import Language.Egison.AST -import Language.Egison.Core import Language.Egison.Data -import Language.Egison.IState (MonadEval(..)) -import Language.Egison.Parser -import Language.Egison.Pretty -import Language.Egison.MathExpr -import Language.Egison.Types -import Language.Egison.Tensor +import Language.Egison.Data.Collection (makeICollection) +import Language.Egison.EvalState (MonadEval(..)) +import Language.Egison.IExpr (stringToVar, Index(..)) +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 - let ops = map (\(name, fn) -> (name, PrimitiveFunc name fn)) (primitives ++ ioPrimitives) - bindings <- forM (constants ++ ops) $ \(name, op) -> do + bindings <- forM (constants ++ primitives ++ ioPrimitives) $ \(name, op) -> do ref <- newIORef . WHNF $ Value op return (stringToVar name, ref) return $ extendEnv nullEnv bindings primitiveEnvNoIO :: IO Env primitiveEnvNoIO = do - let ops = map (\(name, fn) -> (name, PrimitiveFunc name fn)) primitives - bindings <- forM (constants ++ ops) $ \(name, op) -> do + bindings <- forM (constants ++ primitives) $ \(name, op) -> do ref <- newIORef . WHNF $ Value op return (stringToVar name, ref) return $ extendEnv nullEnv bindings -{-# INLINE noArg #-} -noArg :: EvalM EgisonValue -> PrimitiveFunc -noArg f args = do - args' <- tupleToList args - case args' of - [] -> Value <$> f - _ -> throwError =<< ArgumentsNumPrimitive 0 (length args') <$> getFuncNameStack - -{-# INLINE oneArg #-} -oneArg :: (EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc -oneArg f arg = do - arg' <- evalWHNF arg - case arg' of - (TensorData (Tensor ns ds js)) -> do - ds' <- V.mapM f ds - Value <$> fromTensor (Tensor ns ds' js) - _ -> Value <$> f arg' - -{-# INLINE oneArg' #-} -oneArg' :: (EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc -oneArg' f arg = do - arg' <- evalWHNF arg - Value <$> f arg' - -{-# INLINE twoArgs #-} -twoArgs :: (EgisonValue -> EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc -twoArgs f args = do - args' <- tupleToList args - case args' of - [TensorData t1@Tensor{}, TensorData t2@Tensor{}] -> Value <$> (tProduct f t1 t2 >>= fromTensor) - [TensorData(Tensor ns ds js), val] -> do - ds' <- V.mapM (`f` val) ds - Value <$> fromTensor (Tensor ns ds' js) - [val, TensorData (Tensor ns ds js)] -> do - ds' <- V.mapM (f val) ds - Value <$> fromTensor (Tensor ns ds' js) - [val, val'] -> Value <$> f val val' - _ -> throwError =<< ArgumentsNumPrimitive 2 (length args') <$> getFuncNameStack - -{-# INLINE twoArgs' #-} -twoArgs' :: (EgisonValue -> EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc -twoArgs' f args = do - args' <- tupleToList args - case args' of - [val, val'] -> Value <$> f val val' - _ -> throwError =<< ArgumentsNumPrimitive 2 (length args') <$> getFuncNameStack - -{-# INLINE threeArgs' #-} -threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EvalM EgisonValue) -> PrimitiveFunc -threeArgs' f args = do - args' <- tupleToList args - case args' of - [val, val', val''] -> Value <$> f val val' val'' - _ -> throwError =<< ArgumentsNumPrimitive 3 (length args') <$> getFuncNameStack - -- -- Constants -- constants :: [(String, EgisonValue)] -constants = [ - ("f.pi", Float 3.141592653589793) - ,("f.e" , Float 2.718281828459045) - ] +constants = [ ("f.pi", Float 3.141592653589793) + , ("f.e" , Float 2.718281828459045) + ] -- -- Primitives -- -primitives :: [(String, PrimitiveFunc)] -primitives = [ ("b.+", plus) - , ("b.-", minus) - , ("b.*", multiply) - , ("b./", divide) - , ("f.+", floatBinaryOp (+)) - , ("f.-", floatBinaryOp (-)) - , ("f.*", floatBinaryOp (*)) - , ("f./", floatBinaryOp (/)) - , ("numerator", numerator') - , ("denominator", denominator') - , ("fromMathExpr", fromScalarData) - , ("toMathExpr", toScalarData) - , ("toMathExpr'", toScalarData) - - , ("modulo", integerBinaryOp mod) - , ("quotient", integerBinaryOp quot) - , ("remainder", integerBinaryOp rem) - , ("b.abs", rationalUnaryOp abs) - , ("b.neg", rationalUnaryOp negate) - - , ("equal", eq) - , ("lt", scalarCompare (<)) - , ("lte", scalarCompare (<=)) - , ("gt", scalarCompare (>)) - , ("gte", scalarCompare (>=)) - - , ("round", floatToIntegerOp round) - , ("floor", floatToIntegerOp floor) - , ("ceiling", floatToIntegerOp ceiling) - , ("truncate", truncate') - - , ("b.sqrt", floatUnaryOp sqrt) - , ("b.sqrt'", floatUnaryOp sqrt) - , ("b.exp", floatUnaryOp exp) - , ("b.log", floatUnaryOp log) - , ("b.sin", floatUnaryOp sin) - , ("b.cos", floatUnaryOp cos) - , ("b.tan", floatUnaryOp tan) - , ("b.asin", floatUnaryOp asin) - , ("b.acos", floatUnaryOp acos) - , ("b.atan", floatUnaryOp atan) - , ("b.sinh", floatUnaryOp sinh) - , ("b.cosh", floatUnaryOp cosh) - , ("b.tanh", floatUnaryOp tanh) - , ("b.asinh", floatUnaryOp asinh) - , ("b.acosh", floatUnaryOp acosh) - , ("b.atanh", floatUnaryOp atanh) - - , ("tensorShape", tensorShape') - , ("tensorToList", tensorToList') - , ("dfOrder", dfOrder') - - , ("itof", integerToFloat) - , ("rtof", rationalToFloat) - , ("ctoi", charToInteger) - , ("itoc", integerToChar) - - , ("pack", pack) - , ("unpack", unpack) - , ("unconsString", unconsString) - , ("lengthString", lengthString) - , ("appendString", appendString) - , ("splitString", splitString) - , ("regex", regexString) - , ("regexCg", regexStringCaptureGroup) - - , ("addPrime", addPrime) - , ("addSubscript", addSubscript) - , ("addSuperscript", addSuperscript) - - , ("readProcess", readProcess') - - , ("read", read') - , ("readTsv", readTSV) - , ("show", show') - , ("showTsv", showTSV') - - , ("isBool", isBool') - , ("isInteger", isInteger') - , ("isRational", isRational') - , ("isScalar", isScalar') - , ("isFloat", isFloat') - , ("isChar", isChar') - , ("isString", isString') - , ("isCollection", isCollection') - , ("isHash", isHash') - , ("isTensor", isTensor') - - , ("assert", assert) - , ("assertEqual", assertEqual) - ] - -unaryOp :: (EgisonData a, EgisonData b) => (a -> b) -> PrimitiveFunc -unaryOp op = oneArg $ \val -> do - v <- fromEgison val - return $ toEgison (op v) - -binaryOp :: (EgisonData a, EgisonData b) => (a -> a -> b) -> PrimitiveFunc -binaryOp op = twoArgs $ \val val' -> do - i <- fromEgison val - i' <- fromEgison val' - return $ toEgison (op i i') - -rationalUnaryOp :: (Rational -> Rational) -> PrimitiveFunc -rationalUnaryOp = unaryOp - -integerBinaryOp :: (Integer -> Integer -> Integer) -> PrimitiveFunc -integerBinaryOp = binaryOp - -floatUnaryOp :: (Double -> Double) -> PrimitiveFunc -floatUnaryOp = unaryOp - -floatBinaryOp :: (Double -> Double -> Double) -> PrimitiveFunc -floatBinaryOp = binaryOp - --- --- Arith --- - -scalarBinaryOp :: (ScalarData -> ScalarData -> ScalarData) -> PrimitiveFunc -scalarBinaryOp mOp = twoArgs $ \val val' -> scalarBinaryOp' val val' - where - scalarBinaryOp' (ScalarData m1) (ScalarData m2) = (return . ScalarData . mathNormalize') (mOp m1 m2) - scalarBinaryOp' (ScalarData _) val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack - scalarBinaryOp' val _ = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack - -plus :: PrimitiveFunc -plus = scalarBinaryOp mathPlus - -minus :: PrimitiveFunc -minus = scalarBinaryOp (\m1 m2 -> mathPlus m1 (mathNegate m2)) - -multiply :: PrimitiveFunc -multiply = scalarBinaryOp mathMult - -divide :: PrimitiveFunc -divide = scalarBinaryOp (\m1 (Div p1 p2) -> mathMult m1 (Div p2 p1)) - -numerator' :: PrimitiveFunc -numerator' = oneArg numerator'' - where - numerator'' (ScalarData m) = return $ ScalarData (mathNumerator m) - numerator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack - -denominator' :: PrimitiveFunc -denominator' = oneArg denominator'' - where - denominator'' (ScalarData m) = return $ ScalarData (mathDenominator m) - denominator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack - -fromScalarData :: PrimitiveFunc -fromScalarData = oneArg fromScalarData' - where - fromScalarData' (ScalarData m) = return $ mathExprToEgison m - fromScalarData' val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack - -toScalarData :: PrimitiveFunc -toScalarData = oneArg toScalarData' - where - toScalarData' val = ScalarData . mathNormalize' <$> egisonToScalarData val - --- --- Pred --- -eq :: PrimitiveFunc -eq = twoArgs' $ \val val' -> - return $ Bool $ val == val' - -scalarCompare :: (forall a. Ord a => a -> a -> Bool) -> PrimitiveFunc -scalarCompare cmp = twoArgs' $ \val1 val2 -> - case (val1, val2) of - (ScalarData _, ScalarData _) -> do - r1 <- fromEgison val1 :: EvalM Rational - 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 +primitives :: [(String, EgisonValue)] +primitives = + map (\(name, fn) -> (name, PrimitiveFunc (fn name))) strictPrimitives + ++ map (\(name, fn) -> (name, LazyPrimitiveFunc (fn name))) lazyPrimitives + ++ primitiveArithFunctions + ++ primitiveStringFunctions + ++ primitiveTypeFunctions + where + strictPrimitives = + [ ("addSubscript", addSubscript) + , ("addSuperscript", addSuperscript) -truncate' :: PrimitiveFunc -truncate' = oneArg $ \val -> numberUnaryOp' val - where - 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 + , ("assert", assert) + , ("assertEqual", assertEqual) + ] + lazyPrimitives = + [ ("tensorShape", tensorShape') + , ("tensorToList", tensorToList') + , ("dfOrder", dfOrder') + ] -- --- Tensor +-- Miscellaneous primitive functions -- -tensorShape' :: PrimitiveFunc -tensorShape' = oneArg' tensorShape'' +tensorShape' :: String -> LazyPrimitiveFunc +tensorShape' = lazyOneArg tensorShape'' where - tensorShape'' (TensorData (Tensor ns _ _)) = return . Collection . Sq.fromList $ map toEgison ns - tensorShape'' _ = return . Collection $ Sq.fromList [] + tensorShape'' (Value (TensorData (Tensor ns _ _))) = + return . Value . Collection . Sq.fromList $ map toEgison ns + tensorShape'' (ITensor (Tensor ns _ _)) = + return . Value . Collection . Sq.fromList $ map toEgison ns + tensorShape'' _ = return . Value . Collection $ Sq.fromList [] -tensorToList' :: PrimitiveFunc -tensorToList' = oneArg' tensorToList'' +tensorToList' :: String -> LazyPrimitiveFunc +tensorToList' = lazyOneArg tensorToList'' where - tensorToList'' (TensorData (Tensor _ xs _)) = return . Collection . Sq.fromList $ V.toList xs - tensorToList'' x = return . Collection $ Sq.fromList [x] + tensorToList'' (Value (TensorData (Tensor _ xs _))) = + return . Value . Collection . Sq.fromList $ V.toList xs + tensorToList'' (ITensor (Tensor _ xs _)) = do + inners <- liftIO . newIORef $ Sq.fromList (map IElement (V.toList xs)) + return (ICollection inners) + tensorToList'' x = makeICollection [x] -dfOrder' :: PrimitiveFunc -dfOrder' = oneArg' dfOrder'' +dfOrder' :: String -> LazyPrimitiveFunc +dfOrder' = lazyOneArg dfOrder'' where - dfOrder'' (TensorData (Tensor ns _ is)) = return (toEgison (fromIntegral (length ns - length is) :: Integer)) - dfOrder'' _ = return (toEgison (0 :: Integer)) - --- --- Transform --- -integerToFloat :: PrimitiveFunc -integerToFloat = rationalToFloat - -rationalToFloat :: PrimitiveFunc -rationalToFloat = oneArg $ \val -> - case val of - (ScalarData (Div (Plus []) _)) -> return $ Float 0 - (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) -> return $ Float (fromRational (x % y)) - _ -> throwError =<< TypeMismatch "integer or rational number" (Value val) <$> getFuncNameStack - -charToInteger :: PrimitiveFunc -charToInteger = unaryOp ctoi - where - ctoi :: Char -> Integer - ctoi = fromIntegral . ord - -integerToChar :: PrimitiveFunc -integerToChar = unaryOp itoc - where - itoc :: Integer -> Char - itoc = chr . fromIntegral - -floatToIntegerOp :: (Double -> Integer) -> PrimitiveFunc -floatToIntegerOp = unaryOp - --- --- String --- -pack :: PrimitiveFunc -pack = oneArg $ \val -> do - str <- packStringValue val - return $ String str - where - packStringValue :: EgisonValue -> EvalM Text - packStringValue (Collection seq) = do - let ls = toList seq - str <- mapM fromEgison ls - return $ T.pack str - packStringValue (Tuple [val]) = packStringValue val - packStringValue val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack - -unpack :: PrimitiveFunc -unpack = unaryOp T.unpack - -unconsString :: PrimitiveFunc -unconsString = oneArg $ \val -> do - str <- fromEgison val - case T.uncons str of - Just (c, rest) -> return $ Tuple [Char c, String rest] - Nothing -> throwError $ Default "Tried to unsnoc empty string" - -lengthString :: PrimitiveFunc -lengthString = unaryOp (toInteger . T.length) - -appendString :: PrimitiveFunc -appendString = binaryOp T.append - -splitString :: PrimitiveFunc -splitString = twoArgs $ \pat src -> do - patStr <- fromEgison pat - srcStr <- fromEgison src - return . Collection . Sq.fromList $ map String $ T.splitOn patStr srcStr - -regexString :: PrimitiveFunc -regexString = twoArgs $ \pat src -> do - patStr <- fromEgison pat - srcStr <- fromEgison src - case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe (String, String, String)) of - Nothing -> return . Collection . Sq.fromList $ [] - Just (a,b,c) -> return . Collection . Sq.fromList $ [Tuple [String $ T.pack a, String $ T.pack b, String $ T.pack c]] - -regexStringCaptureGroup :: PrimitiveFunc -regexStringCaptureGroup = twoArgs $ \pat src -> do - patStr <- fromEgison pat - srcStr <- fromEgison src - case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe [[String]]) of - Nothing -> return . Collection . Sq.fromList $ [] - Just ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr - return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]] - ---regexStringMatch :: PrimitiveFunc ---regexStringMatch = twoArgs $ \pat src -> do --- case (pat, src) of --- (String patStr, String srcStr) -> return . Bool $ (((T.unpack srcStr) =~ (T.unpack patStr)) :: Bool) --- (String _, _) -> throwError =<< TypeMismatch "string" (Value src) <$> getFuncNameStack --- (_, _) -> throwError =<< TypeMismatch "string" (Value pat) <$> getFuncNameStack - -addPrime :: PrimitiveFunc -addPrime = oneArg $ \sym -> - case sym of - ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])) -> - return (ScalarData (Div (Plus [Term 1 [(Symbol id (name ++ "'") is, 1)]]) (Plus [Term 1 []]))) - _ -> throwError =<< TypeMismatch "symbol" (Value sym) <$> getFuncNameStack + dfOrder'' (Value (TensorData (Tensor ns _ is))) = + return $ Value (toEgison (fromIntegral (length ns - length is) :: Integer)) + dfOrder'' (ITensor (Tensor ns _ is)) = + return $ Value (toEgison (fromIntegral (length ns - length is) :: Integer)) + dfOrder'' _ = return $ Value (toEgison (0 :: Integer)) -addSubscript :: PrimitiveFunc +addSubscript :: String -> PrimitiveFunc addSubscript = twoArgs $ \fn sub -> case (fn, sub) of - (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])), - ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> - return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []]))) - (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])), - ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> - return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Subscript s]), 1)]]) (Plus [Term 1 []]))) - (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])), - _) -> throwError =<< TypeMismatch "symbol or integer" (Value sub) <$> getFuncNameStack + (ScalarData (SingleSymbol (Symbol id name is)), ScalarData s@(SingleSymbol (Symbol _ _ []))) -> + 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 -addSuperscript :: PrimitiveFunc +addSuperscript :: String -> PrimitiveFunc addSuperscript = twoArgs $ \fn sub -> case (fn, sub) of - (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])), - ScalarData s@(Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []]))) -> - return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []]))) - (ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])), - ScalarData s@(Div (Plus [Term _ []]) (Plus [Term 1 []]))) -> - return (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ [Superscript s]), 1)]]) (Plus [Term 1 []]))) - (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])), - _) -> throwError =<< TypeMismatch "symbol" (Value sub) <$> getFuncNameStack + (ScalarData (SingleSymbol (Symbol id name is)), ScalarData s@(SingleSymbol (Symbol _ _ []))) -> + 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 -readProcess' :: PrimitiveFunc -readProcess' = threeArgs' $ \cmd args input -> - case (cmd, args, input) of - (String cmdStr, Collection argStrs, String inputStr) -> do - let cmd' = T.unpack cmdStr - let args' = map (\case String argStr -> T.unpack argStr) (toList argStrs) - let input' = T.unpack inputStr - outputStr <- liftIO $ readProcess cmd' args' input' - return (String (T.pack outputStr)) - (_, _, _) -> throwError =<< TypeMismatch "(string, collection, string)" (Value (Tuple [cmd, args, input])) <$> getFuncNameStack - -read' :: PrimitiveFunc -read'= oneArg' $ \val -> do - str <- fromEgison val - ast <- readExpr False (T.unpack str) - evalExprDeep nullEnv ast - -readTSV :: PrimitiveFunc -readTSV= oneArg' $ \val -> do - str <- fromEgison val - exprs <- readExprs False (T.unpack str) - rets <- mapM (evalExprDeep nullEnv) exprs - case rets of - [ret] -> return ret - _ -> return (Tuple rets) - -show' :: PrimitiveFunc -show'= oneArg' $ \val -> return $ toEgison $ T.pack $ show val - -showTSV' :: PrimitiveFunc -showTSV'= oneArg' $ \val -> return $ toEgison $ T.pack $ showTSV val - --- --- Test --- - -assert :: PrimitiveFunc +assert :: String -> PrimitiveFunc assert = twoArgs' $ \label test -> do test <- fromEgison test if test then return $ Bool True else throwError =<< Assertion (show label) <$> getFuncNameStack -assertEqual :: PrimitiveFunc +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 - --- --- IO Primitives --- - -ioPrimitives :: [(String, PrimitiveFunc)] -ioPrimitives = [ ("return", return') - , ("openInputFile", makePort ReadMode) - , ("openOutputFile", makePort WriteMode) - , ("closeInputPort", closePort) - , ("closeOutputPort", closePort) - , ("readChar", readChar) - , ("readLine", readLine) - , ("writeChar", writeChar) - , ("write", writeString) - - , ("readCharFromPort", readCharFromPort) - , ("readLineFromPort", readLineFromPort) - , ("writeCharToPort", writeCharToPort) - , ("writeToPort", writeStringToPort) - - , ("isEof", isEOFStdin) - , ("flush", flushStdout) - , ("isEofPort", isEOFPort) - , ("flushPort", flushPort) - , ("readFile", readFile') - - , ("rand", randRange) - , ("f.rand", randRangeDouble) - - , ("newIORef", newIORef') - , ("writeIORef", writeIORef') - , ("readIORef", readIORef') - ] - -makeIO :: EvalM EgisonValue -> EgisonValue -makeIO m = IOFunc $ fmap (Value . Tuple . (World :) . (:[])) m - -makeIO' :: EvalM () -> EgisonValue -makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []]) - -return' :: PrimitiveFunc -return' = oneArg' $ \val -> return $ makeIO $ return val - -makePort :: IOMode -> PrimitiveFunc -makePort mode = oneArg' $ \val -> do - filename <- fromEgison val - port <- liftIO $ openFile (T.unpack filename) mode - return $ makeIO $ return (Port port) - -closePort :: PrimitiveFunc -closePort = oneArg' $ \val -> do - port <- fromEgison val - return $ makeIO' $ liftIO $ hClose port - -writeChar :: PrimitiveFunc -writeChar = oneArg' $ \val -> do - c <- fromEgison val - return $ makeIO' $ liftIO $ putChar c - -writeCharToPort :: PrimitiveFunc -writeCharToPort = twoArgs' $ \val val' -> do - port <- fromEgison val - c <- fromEgison val' - return $ makeIO' $ liftIO $ hPutChar port c - -writeString :: PrimitiveFunc -writeString = oneArg' $ \val -> do - s <- fromEgison val - return $ makeIO' $ liftIO $ T.putStr s - -writeStringToPort :: PrimitiveFunc -writeStringToPort = twoArgs' $ \val val' -> do - port <- fromEgison val - s <- fromEgison val' - return $ makeIO' $ liftIO $ T.hPutStr port s - -flushStdout :: PrimitiveFunc -flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout - -flushPort :: PrimitiveFunc -flushPort = oneArg' $ \val -> do - port <- fromEgison val - return $ makeIO' $ liftIO $ hFlush port - -readChar :: PrimitiveFunc -readChar = noArg $ return $ makeIO $ liftIO $ fmap Char getChar - -readCharFromPort :: PrimitiveFunc -readCharFromPort = oneArg' $ \val -> do - port <- fromEgison val - c <- liftIO $ hGetChar port - return $ makeIO $ return (Char c) - -readLine :: PrimitiveFunc -readLine = noArg $ return $ makeIO $ liftIO $ fmap toEgison T.getLine - -readLineFromPort :: PrimitiveFunc -readLineFromPort = oneArg' $ \val -> do - port <- fromEgison val - s <- liftIO $ T.hGetLine port - return $ makeIO $ return $ toEgison s - -readFile' :: PrimitiveFunc -readFile' = oneArg' $ \val -> do - filename <- fromEgison val - s <- liftIO $ T.readFile $ T.unpack filename - return $ makeIO $ return $ toEgison s - -isEOFStdin :: PrimitiveFunc -isEOFStdin = noArg $ return $ makeIO $ liftIO $ fmap Bool isEOF - -isEOFPort :: PrimitiveFunc -isEOFPort = oneArg' $ \val -> do - port <- fromEgison val - b <- liftIO $ hIsEOF port - return $ makeIO $ return (Bool b) - -randRange :: PrimitiveFunc -randRange = twoArgs' $ \val val' -> do - i <- fromEgison val :: EvalM Integer - i' <- fromEgison val' :: EvalM Integer - n <- liftIO $ getStdRandom $ randomR (i, i') - return $ makeIO $ return $ toEgison n - -randRangeDouble :: PrimitiveFunc -randRangeDouble = twoArgs' $ \val val' -> do - i <- fromEgison val :: EvalM Double - i' <- fromEgison val' :: EvalM Double - n <- liftIO $ getStdRandom $ randomR (i, i') - return $ makeIO $ return $ toEgison n - -newIORef' :: PrimitiveFunc -newIORef' = noArg $ do - ref <- liftIO $ newIORef Undefined - return $ makeIO $ return (RefBox ref) - -writeIORef' :: PrimitiveFunc -writeIORef' = twoArgs $ \ref val -> do - ref' <- fromEgison ref - return $ makeIO' $ liftIO $ writeIORef ref' val - -readIORef' :: PrimitiveFunc -readIORef' = oneArg $ \ref -> do - ref' <- fromEgison ref - val <- liftIO $ readIORef ref' - return $ makeIO $ return val - {-- -- for 'egison-sqlite' sqlite :: PrimitiveFunc diff --git a/hs-src/Language/Egison/Primitives/Arith.hs b/hs-src/Language/Egison/Primitives/Arith.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Primitives/Arith.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +{- | +Module : Language.Egison.Primitives.Arith +Licence : MIT + +This module implements arithmetic primitive functions. +-} + +module Language.Egison.Primitives.Arith + ( primitiveArithFunctions + ) where + +import Control.Monad.Except +import Language.Egison.Data +import Language.Egison.EvalState (MonadEval(..)) +import Language.Egison.Primitives.Utils +import Language.Egison.Math + +primitiveArithFunctions :: [(String, EgisonValue)] +primitiveArithFunctions = + map (\(name, fn) -> (name, PrimitiveFunc (fn name))) strictPrimitives + +strictPrimitives :: [(String, String -> PrimitiveFunc)] +strictPrimitives = + [ ("b.+", plus) + , ("b.-", minus) + , ("b.*", multiply) + , ("b./", divide) + , ("f.+", floatBinaryOp (+)) + , ("f.-", floatBinaryOp (-)) + , ("f.*", floatBinaryOp (*)) + , ("f./", floatBinaryOp (/)) + , ("numerator", numerator') + , ("denominator", denominator') + , ("fromMathExpr", fromScalarData) + , ("toMathExpr'", toScalarData) + , ("symbolNormalize", symbolNormalize) + + , ("modulo", integerBinaryOp mod) + , ("quotient", integerBinaryOp quot) + , ("%", integerBinaryOp rem) + , ("b.abs", rationalUnaryOp abs) + , ("b.neg", rationalUnaryOp negate) + + , ("=", eq) + , ("<", scalarCompare (<)) + , ("<=", scalarCompare (<=)) + , (">", scalarCompare (>)) + , (">=", scalarCompare (>=)) + + , ("round", floatToIntegerOp round) + , ("floor", floatToIntegerOp floor) + , ("ceiling", floatToIntegerOp ceiling) + , ("truncate", truncate') + + , ("b.sqrt", floatUnaryOp sqrt) + , ("b.sqrt'", floatUnaryOp sqrt) + , ("b.exp", floatUnaryOp exp) + , ("b.log", floatUnaryOp log) + , ("b.sin", floatUnaryOp sin) + , ("b.cos", floatUnaryOp cos) + , ("b.tan", floatUnaryOp tan) + , ("b.asin", floatUnaryOp asin) + , ("b.acos", floatUnaryOp acos) + , ("b.atan", floatUnaryOp atan) + , ("b.sinh", floatUnaryOp sinh) + , ("b.cosh", floatUnaryOp cosh) + , ("b.tanh", floatUnaryOp tanh) + , ("b.asinh", floatUnaryOp asinh) + , ("b.acosh", floatUnaryOp acosh) + , ("b.atanh", floatUnaryOp atanh) + ] + + +rationalUnaryOp :: (Rational -> Rational) -> String -> PrimitiveFunc +rationalUnaryOp = unaryOp + +integerBinaryOp :: (Integer -> Integer -> Integer) -> String -> PrimitiveFunc +integerBinaryOp = binaryOp + +floatUnaryOp :: (Double -> Double) -> String -> PrimitiveFunc +floatUnaryOp = unaryOp + +floatBinaryOp :: (Double -> Double -> Double) -> String -> PrimitiveFunc +floatBinaryOp = binaryOp + +floatToIntegerOp :: (Double -> Integer) -> String -> PrimitiveFunc +floatToIntegerOp = unaryOp + +-- +-- Arith +-- +scalarBinaryOp :: (ScalarData -> ScalarData -> ScalarData) -> String -> PrimitiveFunc +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 + +plus :: String -> PrimitiveFunc +plus = scalarBinaryOp mathPlus + +minus :: String -> PrimitiveFunc +minus = scalarBinaryOp (\m1 m2 -> mathPlus m1 (mathNegate m2)) + +multiply :: String -> PrimitiveFunc +multiply = scalarBinaryOp mathMult + +divide :: String -> PrimitiveFunc +divide = scalarBinaryOp mathDiv + +numerator' :: String -> PrimitiveFunc +numerator' = oneArg numerator'' + where + numerator'' (ScalarData m) = return $ ScalarData (mathNumerator m) + numerator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack + +denominator' :: String -> PrimitiveFunc +denominator' = oneArg denominator'' + where + denominator'' (ScalarData m) = return $ ScalarData (mathDenominator m) + denominator'' val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack + +fromScalarData :: String -> PrimitiveFunc +fromScalarData = oneArg fromScalarData' + where + fromScalarData' (ScalarData m) = return $ mathExprToEgison m + fromScalarData' val = throwError =<< TypeMismatch "number" (Value val) <$> getFuncNameStack + +toScalarData :: String -> PrimitiveFunc +toScalarData = oneArg $ \val -> + ScalarData . mathNormalize' <$> egisonToScalarData val + +symbolNormalize :: String -> PrimitiveFunc +symbolNormalize = oneArg $ \val -> + case val of + ScalarData s -> return $ ScalarData (rewriteSymbol s) + _ -> throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack + +-- +-- Pred +-- +eq :: String -> PrimitiveFunc +eq = twoArgs' $ \val val' -> + return $ Bool $ val == val' + +scalarCompare :: (forall a. Ord a => a -> a -> Bool) -> String -> PrimitiveFunc +scalarCompare cmp = twoArgs' $ \val1 val2 -> + case (val1, val2) of + (ScalarData _, ScalarData _) -> do + r1 <- fromEgison val1 :: EvalM Rational + 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 + +truncate' :: String -> PrimitiveFunc +truncate' = oneArg $ \val -> numberUnaryOp' val + where + 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 diff --git a/hs-src/Language/Egison/Primitives/IO.hs b/hs-src/Language/Egison/Primitives/IO.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Primitives/IO.hs @@ -0,0 +1,199 @@ +{- | +Module : Language.Egison.Primitives.IO +Licence : MIT + +This module implements primitive functions that performs IO operations. +-} + +module Language.Egison.Primitives.IO + ( ioPrimitives + ) where + +import Control.Monad.Except + +import Data.IORef + +import System.IO +import System.Process (readProcess) +import System.Random (getStdRandom, randomR) + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Language.Egison.Core (evalWHNF) +import Language.Egison.Data +import Language.Egison.EvalState (MonadEval(..)) +import Language.Egison.Primitives.Utils + + +-- +-- IO Primitives +-- + +ioPrimitives :: [(String, EgisonValue)] +ioPrimitives = + map (\(name, fn) -> (name, PrimitiveFunc (fn name))) ioStrictPrimitives ++ + map (\(name, fn) -> (name, LazyPrimitiveFunc (fn name))) ioLazyPrimitives + +ioStrictPrimitives :: [(String, String -> PrimitiveFunc)] +ioStrictPrimitives = + [ ("return", return') + , ("openInputFile", makePort ReadMode) + , ("openOutputFile", makePort WriteMode) + , ("closeInputPort", closePort) + , ("closeOutputPort", closePort) + , ("readChar", readChar) + , ("readLine", readLine) + , ("writeChar", writeChar) + , ("write", writeString) + + , ("readCharFromPort", readCharFromPort) + , ("readLineFromPort", readLineFromPort) + , ("writeCharToPort", writeCharToPort) + , ("writeToPort", writeStringToPort) + + , ("isEof", isEOFStdin) + , ("flush", flushStdout) + , ("isEofPort", isEOFPort) + , ("flushPort", flushPort) + , ("readFile", readFile') + + , ("rand", randRange) + , ("f.rand", randRangeDouble) + + , ("newIORef", newIORef') + , ("writeIORef", writeIORef') + , ("readIORef", readIORef') + + , ("readProcess", readProcess') + ] + +ioLazyPrimitives :: [(String, String -> LazyPrimitiveFunc)] +ioLazyPrimitives = + [ ("io", io) + ] + +makeIO :: EvalM EgisonValue -> EgisonValue +makeIO m = IOFunc $ fmap (Value . Tuple . (World :) . (:[])) m + +makeIO' :: EvalM () -> EgisonValue +makeIO' m = IOFunc $ m >> return (Value $ Tuple [World, Tuple []]) + +return' :: String -> PrimitiveFunc +return' = oneArg' $ \val -> return $ makeIO $ return val + +makePort :: IOMode -> String -> PrimitiveFunc +makePort mode = oneArg' $ \val -> do + filename <- fromEgison val + port <- liftIO $ openFile (T.unpack filename) mode + return $ makeIO $ return (Port port) + +closePort :: String -> PrimitiveFunc +closePort = oneArg' $ \val -> do + port <- fromEgison val + return $ makeIO' $ liftIO $ hClose port + +writeChar :: String -> PrimitiveFunc +writeChar = oneArg' $ \val -> do + c <- fromEgison val + return $ makeIO' $ liftIO $ putChar c + +writeCharToPort :: String -> PrimitiveFunc +writeCharToPort = twoArgs' $ \val val' -> do + port <- fromEgison val + c <- fromEgison val' + return $ makeIO' $ liftIO $ hPutChar port c + +writeString :: String -> PrimitiveFunc +writeString = oneArg' $ \val -> do + s <- fromEgison val + return $ makeIO' $ liftIO $ T.putStr s + +writeStringToPort :: String -> PrimitiveFunc +writeStringToPort = twoArgs' $ \val val' -> do + port <- fromEgison val + s <- fromEgison val' + return $ makeIO' $ liftIO $ T.hPutStr port s + +flushStdout :: String -> PrimitiveFunc +flushStdout = noArg $ return $ makeIO' $ liftIO $ hFlush stdout + +flushPort :: String -> PrimitiveFunc +flushPort = oneArg' $ \val -> do + port <- fromEgison val + return $ makeIO' $ liftIO $ hFlush port + +readChar :: String -> PrimitiveFunc +readChar = noArg $ return $ makeIO $ liftIO (Char <$> getChar) + +readCharFromPort :: String -> PrimitiveFunc +readCharFromPort = oneArg' $ \val -> do + port <- fromEgison val + return . makeIO $ liftIO (Char <$> hGetChar port) + +readLine :: String -> PrimitiveFunc +readLine = noArg $ return $ makeIO $ liftIO (toEgison <$> T.getLine) + +readLineFromPort :: String -> PrimitiveFunc +readLineFromPort = oneArg' $ \val -> do + port <- fromEgison val + return $ makeIO $ liftIO (toEgison <$> T.hGetLine port) + +readFile' :: String -> PrimitiveFunc +readFile' = oneArg' $ \val -> do + filename <- fromEgison val + return $ makeIO $ liftIO (toEgison <$> T.readFile (T.unpack filename)) + +isEOFStdin :: String -> PrimitiveFunc +isEOFStdin = noArg $ return $ makeIO $ liftIO (Bool <$> isEOF) + +isEOFPort :: String -> PrimitiveFunc +isEOFPort = oneArg' $ \val -> do + port <- fromEgison val + return $ makeIO $ liftIO (Bool <$> hIsEOF port) + +randRange :: String -> PrimitiveFunc +randRange = twoArgs' $ \val val' -> do + i <- fromEgison val :: EvalM Integer + i' <- fromEgison val' :: EvalM Integer + return $ makeIO $ liftIO (toEgison <$> getStdRandom (randomR (i, i'))) + +randRangeDouble :: String -> PrimitiveFunc +randRangeDouble = twoArgs' $ \val val' -> do + i <- fromEgison val :: EvalM Double + i' <- fromEgison val' :: EvalM Double + return $ makeIO $ liftIO (toEgison <$> getStdRandom (randomR (i, i'))) + +newIORef' :: String -> PrimitiveFunc +newIORef' = noArg $ do + ref <- liftIO $ newIORef Undefined + return $ makeIO $ return (RefBox ref) + +writeIORef' :: String -> PrimitiveFunc +writeIORef' = twoArgs $ \ref val -> do + ref' <- fromEgison ref + return $ makeIO' $ liftIO $ writeIORef ref' val + +readIORef' :: String -> PrimitiveFunc +readIORef' = oneArg $ \ref -> do + ref' <- fromEgison ref + return $ makeIO $ liftIO $ readIORef ref' + +readProcess' :: String -> PrimitiveFunc +readProcess' = threeArgs' $ \cmd args input -> do + cmd' <- T.unpack <$> fromEgison cmd + args' <- map T.unpack <$> fromEgison args + input' <- T.unpack <$> fromEgison input + return $ makeIO $ do + outputStr <- liftIO $ readProcess cmd' args' input' + return (String (T.pack outputStr)) + +io :: String -> LazyPrimitiveFunc +io = lazyOneArg io' + where + io' (Value (IOFunc m)) = do + val <- m >>= evalWHNF + case val of + Tuple [_, val'] -> return $ Value val' + _ -> throwError =<< TypeMismatch "io" (Value val) <$> getFuncNameStack + io' whnf = throwError =<< TypeMismatch "io" whnf <$> getFuncNameStack diff --git a/hs-src/Language/Egison/Primitives/String.hs b/hs-src/Language/Egison/Primitives/String.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Primitives/String.hs @@ -0,0 +1,112 @@ +{- | +Module : Language.Egison.Primitives.String +Licence : MIT + +This module implements primitive functions that operates on / returns strings. +-} + +module Language.Egison.Primitives.String + ( primitiveStringFunctions + ) where + +import Control.Monad.Except + +import qualified Data.Sequence as Sq +import qualified Data.Text as T + +import Text.Regex.TDFA ((=~~)) + +import Language.Egison.Data +import Language.Egison.Eval +import Language.Egison.Parser +import Language.Egison.Pretty +import Language.Egison.Primitives.Utils + + +primitiveStringFunctions :: [(String, EgisonValue)] +primitiveStringFunctions = + map (\(name, fn) -> (name, PrimitiveFunc (fn name))) strictPrimitives + +strictPrimitives :: [(String, String -> PrimitiveFunc)] +strictPrimitives = + [ ("pack", pack) + , ("unpack", unpack) + , ("unconsString", unconsString) + , ("lengthString", lengthString) + , ("appendString", appendString) + , ("splitString", splitString) + , ("regex", regexString) + , ("regexCg", regexStringCaptureGroup) + + , ("read", read') + , ("readTsv", readTSV) + , ("show", show') + , ("showTsv", showTSV') + ] + +pack :: String -> PrimitiveFunc +pack = unaryOp T.pack + +unpack :: String -> PrimitiveFunc +unpack = unaryOp T.unpack + +unconsString :: String -> PrimitiveFunc +unconsString = oneArg $ \val -> do + str <- fromEgison val + case T.uncons str of + Just (c, rest) -> return $ Tuple [Char c, String rest] + Nothing -> throwError $ Default "Tried to unsnoc empty string" + +lengthString :: String -> PrimitiveFunc +lengthString = unaryOp (toInteger . T.length) + +appendString :: String -> PrimitiveFunc +appendString = binaryOp T.append + +splitString :: String -> PrimitiveFunc +splitString = twoArgs $ \pat src -> do + patStr <- fromEgison pat + srcStr <- fromEgison src + return . Collection . Sq.fromList $ map String $ T.splitOn patStr srcStr + +regexString :: String -> PrimitiveFunc +regexString = twoArgs $ \pat src -> do + patStr <- fromEgison pat + srcStr <- fromEgison src + case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe (String, String, String)) of + Nothing -> return . Collection . Sq.fromList $ [] + Just (a,b,c) -> return . Collection . Sq.fromList $ [Tuple [String (T.pack a), String (T.pack b), String (T.pack c)]] + +regexStringCaptureGroup :: String -> PrimitiveFunc +regexStringCaptureGroup = twoArgs $ \pat src -> do + patStr <- fromEgison pat + srcStr <- fromEgison src + case (T.unpack srcStr =~~ T.unpack patStr) :: (Maybe [[String]]) of + Nothing -> return . Collection . Sq.fromList $ [] + Just ((x:xs):_) -> do let (a, c) = T.breakOn (T.pack x) srcStr + return . Collection . Sq.fromList $ [Tuple [String a, Collection (Sq.fromList (map (String . T.pack) xs)), String (T.drop (length x) c)]] + +-- +-- Read / Show +-- + +read' :: String -> PrimitiveFunc +read'= oneArg' $ \val -> do + str <- fromEgison val + ast <- readExpr (T.unpack str) + evalExpr nullEnv ast + +readTSV :: String -> PrimitiveFunc +readTSV = oneArg' $ \val -> do + str <- fromEgison val + exprs <- mapM (readExpr . T.unpack) (T.split (== '\t') str) + rets <- mapM (evalExpr nullEnv) exprs + case rets of + [ret] -> return ret + _ -> return (Tuple rets) + +show' :: String -> PrimitiveFunc +show'= oneArg' $ \val -> return $ toEgison $ T.pack $ show val + +showTSV' :: String -> PrimitiveFunc +showTSV'= oneArg' $ \val -> return $ toEgison $ T.pack $ showTSV val diff --git a/hs-src/Language/Egison/Primitives/Types.hs b/hs-src/Language/Egison/Primitives/Types.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Primitives/Types.hs @@ -0,0 +1,126 @@ +{- | +Module : Language.Egison.Primitives.Types +Licence : MIT + +This module implements primitive functions that dynamically checks the types of +objects. +-} + +module Language.Egison.Primitives.Types + ( 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 + +primitiveTypeFunctions :: [(String, EgisonValue)] +primitiveTypeFunctions = + map (\(name, fn) -> (name, PrimitiveFunc (fn name))) strictPrimitives ++ + map (\(name, fn) -> (name, LazyPrimitiveFunc (fn name))) lazyPrimitives + +strictPrimitives :: [(String, String -> PrimitiveFunc)] +strictPrimitives = + [ ("itof", integerToFloat) + , ("rtof", rationalToFloat) + , ("ctoi", charToInteger) + , ("itoc", integerToChar) + ] + +lazyPrimitives :: [(String, String -> LazyPrimitiveFunc)] +lazyPrimitives = + [ ("isBool", lazyOneArg isBool) + , ("isInteger", lazyOneArg isInteger) + , ("isRational", lazyOneArg isRational) + , ("isScalar", lazyOneArg isScalar) + , ("isFloat", lazyOneArg isFloat) + , ("isChar", lazyOneArg isChar) + , ("isString", lazyOneArg isString) + , ("isCollection", lazyOneArg isCollection) + , ("isHash", lazyOneArg isHash) + , ("isTensor", lazyOneArg isTensor) + ] + +-- +-- Typing +-- + +isBool :: WHNFData -> EvalM WHNFData +isBool (Value (Bool _)) = return . Value $ Bool True +isBool _ = return . Value $ Bool False + +isInteger :: WHNFData -> EvalM WHNFData +isInteger (Value (ScalarData (Div (Plus []) (Plus [Term 1 []])))) = return . Value $ Bool True +isInteger (Value (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []])))) = return . Value $ Bool True +isInteger _ = return . Value $ Bool False + +isRational :: WHNFData -> EvalM WHNFData +isRational (Value (ScalarData (Div (Plus []) (Plus [Term _ []])))) = return . Value $ Bool True +isRational (Value (ScalarData (Div (Plus [Term _ []]) (Plus [Term _ []])))) = return . Value $ Bool True +isRational _ = return . Value $ Bool False + +isScalar :: WHNFData -> EvalM WHNFData +isScalar (Value (ScalarData _)) = return . Value $ Bool True +isScalar _ = return . Value $ Bool False + +isTensor :: WHNFData -> EvalM WHNFData +isTensor (Value (TensorData _)) = return . Value $ Bool True +isTensor (ITensor _) = return . Value $ Bool True +isTensor _ = return . Value $ Bool False + +isFloat :: WHNFData -> EvalM WHNFData +isFloat (Value (Float _)) = return . Value $ Bool True +isFloat _ = return . Value $ Bool False + +isChar :: WHNFData -> EvalM WHNFData +isChar (Value (Char _)) = return . Value $ Bool True +isChar _ = return . Value $ Bool False + +isString :: WHNFData -> EvalM WHNFData +isString (Value (String _)) = return . Value $ Bool True +isString _ = return . Value $ Bool False + +isCollection :: WHNFData -> EvalM WHNFData +isCollection (Value (Collection _)) = return . Value $ Bool True +isCollection (ICollection _) = return . Value $ Bool True +isCollection _ = return . Value $ Bool False + +isHash :: WHNFData -> EvalM WHNFData +isHash (Value (IntHash _)) = return . Value $ Bool True +isHash (Value (CharHash _)) = return . Value $ Bool True +isHash (Value (StrHash _)) = return . Value $ Bool True +isHash (IIntHash _) = return . Value $ Bool True +isHash (ICharHash _) = return . Value $ Bool True +isHash (IStrHash _) = return . Value $ Bool True +isHash _ = return . Value $ Bool False + +-- +-- Transform +-- +integerToFloat :: String -> PrimitiveFunc +integerToFloat = rationalToFloat + +rationalToFloat :: String -> PrimitiveFunc +rationalToFloat = oneArg $ \val -> + case val of + ScalarData (Div (Plus []) _) -> return $ Float 0 + ScalarData (Div (Plus [Term x []]) (Plus [Term y []])) -> return $ Float (fromRational (x % y)) + _ -> throwError =<< TypeMismatch "integer or rational number" (Value val) <$> getFuncNameStack + +charToInteger :: String -> PrimitiveFunc +charToInteger = unaryOp ctoi + where + ctoi :: Char -> Integer + ctoi = fromIntegral . ord + +integerToChar :: String -> PrimitiveFunc +integerToChar = unaryOp itoc + where + itoc :: Integer -> Char + itoc = chr . fromIntegral diff --git a/hs-src/Language/Egison/Primitives/Utils.hs b/hs-src/Language/Egison/Primitives/Utils.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/Primitives/Utils.hs @@ -0,0 +1,102 @@ +{- | +Module : Language.Egison.Primitives.Utils +Licence : MIT +-} + +module Language.Egison.Primitives.Utils + ( noArg + , oneArg + , oneArg' + , twoArgs + , twoArgs' + , threeArgs' + , lazyOneArg + , unaryOp + , binaryOp + ) where + +import Control.Monad.Except + +import qualified Data.Vector as V + +import Language.Egison.Data +import Language.Egison.EvalState (MonadEval(..)) +import Language.Egison.Tensor + +{-# INLINE noArg #-} +noArg :: EvalM EgisonValue -> String -> PrimitiveFunc +noArg f name args = + case args of + [] -> f + [Tuple []] -> f + _ -> + throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack + +{-# INLINE oneArg #-} +oneArg :: (EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc +oneArg f name args = + case args of + [TensorData (Tensor ns ds js)] -> do + ds' <- V.mapM f ds + return $ TensorData (Tensor ns ds' js) + [arg] -> f arg + _ -> + throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack + +{-# 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 + +{-# 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 + [TensorData(Tensor ns ds js), val] -> do + ds' <- V.mapM (`f` val) ds + return $ TensorData (Tensor ns ds' js) + [val, TensorData (Tensor ns ds js)] -> do + ds' <- V.mapM (f val) ds + 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 + +{-# INLINE twoArgs' #-} +twoArgs' :: (EgisonValue -> EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc +twoArgs' f name args = + case args of + [val, val'] -> f val val' + [val] -> return . PrimitiveFunc $ oneArg' (f val) name + _ -> throwError =<< ArgumentsNumPrimitive name 2 (length args) <$> getFuncNameStack + +{-# INLINE threeArgs' #-} +threeArgs' :: (EgisonValue -> EgisonValue -> EgisonValue -> EvalM EgisonValue) -> String -> PrimitiveFunc +threeArgs' f name args = + case args of + [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 + +lazyOneArg :: (WHNFData -> EvalM WHNFData) -> String -> LazyPrimitiveFunc +lazyOneArg f name args = + case args of + [arg] -> f arg + _ -> throwError =<< ArgumentsNumPrimitive name 1 (length args) <$> getFuncNameStack + +unaryOp :: (EgisonData a, EgisonData b) => (a -> b) -> String -> PrimitiveFunc +unaryOp op = oneArg $ \val -> do + v <- fromEgison val + return $ toEgison (op v) + +binaryOp :: (EgisonData a, EgisonData b) => (a -> a -> b) -> String -> PrimitiveFunc +binaryOp op = twoArgs $ \val val' -> do + i <- fromEgison val + i' <- fromEgison val' + return $ toEgison (op i i') diff --git a/hs-src/Language/Egison/RState.hs b/hs-src/Language/Egison/RState.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Egison/RState.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{- | +Module : Language.Egison.RState +Licence : MIT + +This module defines runtime state. +-} + +module Language.Egison.RState + ( RState (..) + , RuntimeT + , RuntimeM + , MonadRuntime (..) + , runRuntimeT + , evalRuntimeT + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + +import Language.Egison.AST +import Language.Egison.CmdOptions + +-- +-- Runtime State +-- + +data RState = RState + { indexCounter :: Int + , exprOps :: [Op] + , patternOps :: [Op] + } + +initialRState :: RState +initialRState = RState + { indexCounter = 0 + , exprOps = reservedExprOp + , patternOps = reservedPatternOp + } + +type RuntimeT m = ReaderT EgisonOpts (StateT RState m) + +type RuntimeM = RuntimeT IO + +class (Applicative m, Monad m) => MonadRuntime m where + fresh :: m String + +instance Monad m => MonadRuntime (RuntimeT m) where + fresh = do + st <- lift get + lift (modify (\st -> st { indexCounter = indexCounter st + 1 })) + return $ "$_" ++ show (indexCounter st) + +runRuntimeT :: Monad m => EgisonOpts -> RuntimeT m a -> m (a, RState) +runRuntimeT opts = flip runStateT initialRState . flip runReaderT opts + +evalRuntimeT :: Monad m => EgisonOpts -> RuntimeT m a -> m a +evalRuntimeT opts = flip evalStateT initialRState . flip runReaderT opts 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,9 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Language.Egison.Tensor @@ -12,27 +13,21 @@ -} module Language.Egison.Tensor - ( + ( TensorComponent (..) -- * Tensor - initTensor - , tToList - , tIndex , tref , enumTensorIndices , changeIndex , tTranspose , tTranspose' , tFlipIndices - , appendDFscripts - , removeDFscripts + , appendDF + , removeDF , tMap , tMap2 - , tMapN - , tSum , tProduct , tContract , tContract' - , tConcat , tConcat' ) where @@ -40,32 +35,64 @@ import Control.Monad.Except hiding (join) import qualified Data.Vector as V -import Data.List (delete, find, findIndex, - partition, (\\)) +import Data.List (delete, intersect, partition, (\\)) -import Control.Egison hiding (Integer) +import Control.Egison import qualified Control.Egison as M -import Language.Egison.AST hiding (PatVar) import Language.Egison.Data -import Language.Egison.IState (fresh, getFuncNameStack) -import Language.Egison.MathExpr +import Language.Egison.Data.Utils +import Language.Egison.EvalState (getFuncNameStack) +import Language.Egison.IExpr (Index(..), extractSupOrSubIndex) +import Language.Egison.Math +import Language.Egison.RState + +data IndexM m = IndexM m +instance M.Matcher m a => M.Matcher (IndexM m) (Index a) + +sub :: M.Matcher m a => M.Pattern (PP a) (IndexM m) (Index a) a +sub _ _ (Sub a) = pure a +sub _ _ _ = mzero +subM :: M.Matcher m a => IndexM m -> Index a -> m +subM (IndexM m) _ = m + +sup :: M.Matcher m a => M.Pattern (PP a) (IndexM m) (Index a) a +sup _ _ (Sup a) = pure a +sup _ _ _ = mzero +supM :: M.Matcher m a => IndexM m -> Index a -> m +supM (IndexM m) _ = m + +supsub :: M.Matcher m a => M.Pattern (PP a) (IndexM m) (Index a) a +supsub _ _ (SupSub a) = pure a +supsub _ _ _ = mzero +supsubM :: M.Matcher m a => IndexM m -> Index a -> m +supsubM (IndexM m) _ = m + -- -- Tensors -- -initTensor :: Shape -> [a] -> Tensor a -initTensor ns xs = Tensor ns (V.fromList xs) [] +class TensorComponent a b | a -> b where + fromTensor :: Tensor b -> EvalM a + toTensor :: a -> EvalM (Tensor b) +instance TensorComponent EgisonValue EgisonValue where + fromTensor t@Tensor{} = return $ TensorData t + fromTensor (Scalar x) = return x + toTensor (TensorData t) = return t + toTensor x = return $ Scalar x + +instance TensorComponent WHNFData ObjectRef where + fromTensor t@Tensor{} = return $ ITensor t + fromTensor (Scalar x) = evalRef x + toTensor (ITensor t) = return t + toTensor x = Scalar <$> newEvaluatedObjectRef x + tShape :: Tensor a -> Shape tShape (Tensor ns _ _) = ns tShape (Scalar _) = [] -tToList :: Tensor a -> [a] -tToList (Tensor _ xs _) = V.toList xs -tToList (Scalar x) = [x] - tToVector :: Tensor a -> V.Vector a tToVector (Tensor _ xs _) = xs tToVector (Scalar x) = V.fromList [x] @@ -74,80 +101,60 @@ tIndex (Tensor _ _ js) = js tIndex (Scalar _) = [] -tIntRef' :: HasTensor a => Integer -> Tensor a -> EvalM a +tIntRef' :: Integer -> Tensor a -> EvalM (Tensor a) tIntRef' i (Tensor [n] xs _) = if 0 < i && i <= n - then fromTensor $ Scalar $ xs V.! fromIntegral (i - 1) + then return . Scalar $ xs V.! fromIntegral (i - 1) else throwError =<< TensorIndexOutOfBounds i n <$> getFuncNameStack tIntRef' i (Tensor (n:ns) xs js) = if 0 < i && i <= n - then let w = fromIntegral (product ns) in - let ys = V.take w (V.drop (w * fromIntegral (i - 1)) xs) in - fromTensor $ Tensor ns ys (cdr js) + 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 tIntRef' _ _ = throwError $ Default "More indices than the order of the tensor" -tIntRef :: HasTensor a => [Integer] -> Tensor a -> EvalM (Tensor a) +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 tIntRef [] t = return t -tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms +tIntRef (m:ms) t = tIntRef' m t >>= tIntRef ms --- TODO(momohatt): Refactor. -tref :: HasTensor a => [Index EgisonValue] -> Tensor a -> EvalM a +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 (m:ms) t = tIntRef' m t >>= tIntRef1 ms + +pattern SupOrSubIndex :: a -> Index a +pattern SupOrSubIndex i <- (extractSupOrSubIndex -> Just i) + +tref :: [Index EgisonValue] -> Tensor a -> EvalM (Tensor a) tref [] (Tensor [] xs _) - | V.length xs == 1 = fromTensor $ Scalar (xs V.! 0) + | V.length xs == 1 = return $ Scalar (xs V.! 0) | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack -tref [] t = fromTensor t -tref (s@(Subscript (ScalarData (SingleSymbol _))):ms) (Tensor (_:ns) xs js) = do - let yss = split (product ns) xs - ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss - mapM toTensor ts >>= tConcat s >>= fromTensor -tref (s@(Superscript (ScalarData (SingleSymbol _))):ms) (Tensor (_:ns) xs js) = do - let yss = split (product ns) xs - ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss - mapM toTensor ts >>= tConcat s >>= fromTensor -tref (s@(SupSubscript (ScalarData (SingleSymbol _))):ms) (Tensor (_:ns) xs js) = do +tref [] t = return t +tref (s@(SupOrSubIndex (ScalarData (SingleSymbol _))):ms) (Tensor (_:ns) xs js) = do let yss = split (product ns) xs ts <- mapM (\ys -> tref ms (Tensor ns ys (cdr js))) yss - mapM toTensor ts >>= tConcat s >>= fromTensor -tref (Subscript (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= toTensor >>= tref ms -tref (Superscript (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= toTensor >>= tref ms -tref (SupSubscript (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= toTensor >>= tref ms -tref (Subscript (ScalarData ZeroExpr):_) _ = throwError $ Default "tensor index out of bounds: 0" -tref (Superscript (ScalarData ZeroExpr):_) _ = throwError $ Default "tensor index out of bounds: 0" -tref (SupSubscript (ScalarData ZeroExpr):_) _ = throwError $ Default "tensor index out of bounds: 0" -tref (Subscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do - m <- fromEgison mVal - n <- fromEgison nVal - if m > n - then - fromTensor (Tensor (replicate (length is) 0) V.empty []) - else do - ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n] - symId <- fresh - tConcat (Subscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor -tref (Superscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do - m <- fromEgison mVal - n <- fromEgison nVal - if m > n - then - fromTensor (Tensor (replicate (length is) 0) V.empty []) - else do - ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n] - symId <- fresh - tConcat (Superscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor -tref (SupSubscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do + tConcat s ts +tref (SupOrSubIndex (ScalarData (SingleTerm m [])):ms) t = tIntRef' m t >>= tref ms +tref (SupOrSubIndex (ScalarData ZeroExpr):_) _ = throwError $ Default "tensor index out of bounds: 0" +tref (s@(SupOrSubIndex (Tuple [mVal, nVal])):ms) t@(Tensor is _ _) = do m <- fromEgison mVal n <- fromEgison nVal if m > n then - fromTensor (Tensor (replicate (length is) 0) V.empty []) + return (Tensor (replicate (length is) 0) V.empty []) else do - ts <- mapM (\i -> tIntRef' i t >>= toTensor >>= tref ms >>= toTensor) [m..n] + ts <- mapM (\i -> tIntRef' i t >>= tref ms) [m..n] symId <- fresh - tConcat (SupSubscript (symbolScalarData "" (":::" ++ symId))) ts >>= fromTensor + let index = symbolScalarData "" (":::" ++ symId) + case s of + Sub{} -> tConcat (Sub index) ts + Sup{} -> tConcat (Sup index) ts + SupSub{} -> tConcat (SupSub index) ts tref (_:_) _ = throwError $ Default "Tensor index must be an integer or a single symbol." -- Enumarates all indices (1-indexed) from shape @@ -159,107 +166,83 @@ enumTensorIndices (n:ns) = concatMap (\i -> map (i:) (enumTensorIndices ns)) [1..n] changeIndex :: Index String -> EgisonValue -> Index String -changeIndex (Superscript s) m = Superscript (s ++ show m) -changeIndex (Subscript s) m = Subscript (s ++ show m) +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] -> [Integer] -> EvalM [Integer] +transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> Shape -> EvalM Shape transIndex is js ns = do - mapM (\j -> matchDFS (zip is ns) (List (Pair Eql M.Something)) - [[mc| _ ++ (#j, $n) : _ -> return n |] - ,[mc| _ -> throwError $ Default "cannot transpose becuase of the inconsitent symbolic tensor indices" |]]) + mapM (\j -> case lookup j (zip is ns) of + Just n -> return n + Nothing -> throwError $ Default "cannot transpose becuase of the inconsitent symbolic tensor indices") js -tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EvalM (Tensor a) -tTranspose is t@(Tensor ns _ js) = - if length is <= length js - then do let js' = take (length is) js - let k = fromIntegral (length ns - length is) - let ds = map (DFscript 0) [1..k] - ns' <- transIndex (js' ++ ds) (is ++ ds) ns - xs' <- V.fromList <$> mapM (transIndex (is ++ ds) (js' ++ ds)) (enumTensorIndices ns') >>= mapM (`tIntRef` t) >>= mapM fromTensor - return $ Tensor ns' xs' is - else return t +tTranspose :: [Index EgisonValue] -> Tensor a -> EvalM (Tensor a) +tTranspose is t@(Tensor _ _ js) | length is > length js = + return t +tTranspose is t@(Tensor ns _ js) = do + 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) + return $ Tensor ns' xs' is -tTranspose' :: HasTensor a => [EgisonValue] -> Tensor a -> EvalM (Tensor a) -tTranspose' is t@(Tensor _ _ js) = do - case g is js of +tTranspose' :: [EgisonValue] -> Tensor a -> EvalM (Tensor a) +tTranspose' is t@(Tensor _ _ js) = + case mapM (\i -> f i js) is of Nothing -> return t Just is' -> tTranspose is' t where - f :: Index EgisonValue -> EgisonValue - f (Subscript i) = i - f (Superscript i) = i - f (SupSubscript i) = i - g :: [EgisonValue] -> [Index EgisonValue] -> Maybe [Index EgisonValue] - g [] _ = return [] - g (i:is) js = case find (\j -> i == f j) js of - Nothing -> Nothing - Just j' -> do js' <- g is js - return $ j':js' + f :: EgisonValue -> [Index EgisonValue] -> Maybe (Index EgisonValue) + f i js = + match dfs js (List (IndexM Eql)) + [ [mc| _ ++ ($j & (sub #i | sup #i | supsub #i)) : _ -> Just j |] + , [mc| _ -> Nothing |] + ] -tFlipIndices :: HasTensor a => Tensor a -> EvalM (Tensor a) -tFlipIndices (Tensor ns xs js) = return $ Tensor ns xs (map flipIndex js) - where - flipIndex (Subscript i) = Superscript i - flipIndex (Superscript i) = Subscript i - flipIndex x = x +tFlipIndices :: Tensor a -> EvalM (Tensor a) +tFlipIndices (Tensor ns xs js) = return $ Tensor ns xs (map reverseIndex js) -appendDFscripts :: Integer -> WHNFData -> EvalM WHNFData -appendDFscripts id (Intermediate (ITensor (Tensor s xs is))) = do +appendDF :: Integer -> WHNFData -> WHNFData +appendDF id (ITensor (Tensor s xs is)) = let k = fromIntegral (length s - length is) - return $ Intermediate (ITensor (Tensor s xs (is ++ map (DFscript id) [1..k]))) -appendDFscripts id (Value (TensorData (Tensor s xs is))) = do + in ITensor (Tensor s xs (is ++ map (DF id) [1..k])) +appendDF id (Value (TensorData (Tensor s xs is))) = let k = fromIntegral (length s - length is) - return $ Value (TensorData (Tensor s xs (is ++ map (DFscript id) [1..k]))) -appendDFscripts _ whnf = return whnf + in Value (TensorData (Tensor s xs (is ++ map (DF id) [1..k]))) +appendDF _ whnf = whnf -removeDFscripts :: WHNFData -> EvalM WHNFData -removeDFscripts (Intermediate (ITensor (Tensor s xs is))) = do +removeDF :: WHNFData -> EvalM WHNFData +removeDF (ITensor (Tensor s xs is)) = do let (ds, js) = partition isDF is Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is) - return (Intermediate (ITensor (Tensor s ys js))) + return (ITensor (Tensor s ys js)) where - isDF (DFscript _ _) = True - isDF _ = False -removeDFscripts (Value (TensorData (Tensor s xs is))) = do + isDF (DF _ _) = True + isDF _ = False +removeDF (Value (TensorData (Tensor s xs is))) = do let (ds, js) = partition isDF is Tensor s ys _ <- tTranspose (js ++ ds) (Tensor s xs is) return (Value (TensorData (Tensor s ys js))) where - isDF (DFscript _ _) = True - isDF _ = False -removeDFscripts whnf = return whnf + isDF (DF _ _) = True + isDF _ = False +removeDF whnf = return whnf -tMap :: HasTensor a => (a -> EvalM a) -> Tensor a -> EvalM (Tensor a) +tMap :: (a -> EvalM b) -> Tensor a -> EvalM (Tensor b) tMap f (Tensor ns xs js') = do - let k = fromIntegral $ length ns - length js' - let js = js' ++ map (DFscript 0) [1..k] - xs' <- V.fromList <$> mapM f (V.toList xs) - t <- toTensor (V.head xs') - case t of - Tensor ns1 _ js1' -> do - let k1 = fromIntegral $ length ns1 - length js1' - let js1 = js1' ++ map (DFscript 0) [1..k1] - tContract' $ Tensor (ns ++ ns1) (V.concat (V.toList (V.map tensorElems xs'))) (js ++ js1) - _ -> return $ Tensor ns xs' js + let js = js' ++ complementWithDF ns js' + xs' <- V.mapM f xs + return $ Tensor ns xs' js tMap f (Scalar x) = Scalar <$> f x -tMapN :: HasTensor a => ([a] -> EvalM a) -> [Tensor a] -> EvalM (Tensor a) -tMapN f ts@(Tensor ns _ js : _) = do - xs' <- mapM (\is -> mapM (tIntRef is) ts >>= mapM fromTensor >>= f) (enumTensorIndices ns) - return $ Tensor ns (V.fromList xs') js -tMapN f xs = Scalar <$> (mapM fromTensor xs >>= f) - -tMap2 :: HasTensor a => (a -> a -> EvalM a) -> Tensor a -> Tensor a -> EvalM (Tensor a) +tMap2 :: (a -> b -> EvalM c) -> Tensor a -> Tensor b -> EvalM (Tensor c) tMap2 f (Tensor ns1 xs1 js1') (Tensor ns2 xs2 js2') = do - let k1 = fromIntegral $ length ns1 - length js1' - let js1 = js1' ++ map (DFscript 0) [1..k1] - let k2 = fromIntegral $ length ns2 - length js2' - let js2 = js2' ++ map (DFscript 0) [1..k2] - let (cjs, tjs1, tjs2) = h js1 js2 - t1' <- tTranspose (cjs ++ tjs1) (Tensor ns1 xs1 js1) - t2' <- tTranspose (cjs ++ tjs2) (Tensor ns2 xs2 js2) + let js1 = js1' ++ complementWithDF ns1 js1' + let js2 = js2' ++ complementWithDF ns2 js2' + let cjs = js1 `intersect` js2 + t1' <- tTranspose (cjs ++ (js1 \\ cjs)) (Tensor ns1 xs1 js1) + t2' <- tTranspose (cjs ++ (js2 \\ cjs)) (Tensor ns2 xs2 js2) let cns = take (length cjs) (tShape t1') rts1 <- mapM (`tIntRef` t1') (enumTensorIndices cns) rts2 <- mapM (`tIntRef` t2') (enumTensorIndices cns) @@ -267,9 +250,6 @@ let ret = Tensor (cns ++ tShape (head rts')) (V.concat (map tToVector rts')) (cjs ++ tIndex (head rts')) tTranspose (uniq (tDiagIndex (js1 ++ js2))) ret where - h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue]) - h js1 js2 = let cjs = filter (`elem` js2) js1 in - (cjs, js1 \\ cjs, js2 \\ cjs) uniq :: [Index EgisonValue] -> [Index EgisonValue] uniq [] = [] uniq (x:xs) = x:uniq (delete x xs) @@ -277,7 +257,7 @@ tMap2 f (Scalar x) t@Tensor{} = tMap (f x) t tMap2 f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2 -tDiag :: HasTensor a => Tensor a -> EvalM (Tensor a) +tDiag :: Tensor a -> EvalM (Tensor a) tDiag t@(Tensor _ _ js) = case filter (\j -> any (p j) js) js of [] -> return t @@ -285,126 +265,109 @@ let ys = js \\ (xs ++ map reverseIndex xs) t2 <- tTranspose (xs ++ map reverseIndex xs ++ ys) t let (ns1, tmp) = splitAt (length xs) (tShape t2) - let (_, ns2) = splitAt (length xs) tmp + let ns2 = drop (length xs) tmp ts <- mapM (\is -> tIntRef (is ++ is) t2) (enumTensorIndices ns1) - return $ Tensor (ns1 ++ ns2) (V.concat (map tToVector ts)) (map toSupSubscript xs ++ ys) + return $ Tensor (ns1 ++ ns2) (V.concat (map tToVector ts)) (map toSupSub xs ++ ys) where p :: Index EgisonValue -> Index EgisonValue -> Bool - p (Superscript i) (Subscript j) = i == j - p (Subscript _) _ = False - p _ _ = False + p (Sup i) (Sub j) = i == j + p _ _ = False tDiag t = return t tDiagIndex :: [Index EgisonValue] -> [Index EgisonValue] tDiagIndex js = - let xs = filter (\j -> any (p j) js) js - ys = js \\ (xs ++ map reverseIndex xs) - in map toSupSubscript xs ++ ys - where - p :: Index EgisonValue -> Index EgisonValue -> Bool - p (Superscript i) (Subscript j) = i == j - p (Subscript _) _ = False - p _ _ = False - -tSum :: HasTensor a => (a -> a -> EvalM a) -> Tensor a -> Tensor a -> EvalM (Tensor a) -tSum f (Tensor ns1 xs1 js1) t2@Tensor{} = do - t2' <- tTranspose js1 t2 - case t2' of - (Tensor ns2 xs2 _) - | ns2 == ns1 -> do ys <- V.mapM (uncurry f) (V.zip xs1 xs2) - return (Tensor ns1 ys js1) - | otherwise -> throwError =<< InconsistentTensorShape <$> getFuncNameStack + match dfs js (List (IndexM Eql)) + [ [mc| $hjs ++ sup $i : $mjs ++ sub #i : $tjs -> + tDiagIndex (SupSub i : hjs ++ mjs ++ tjs) |] + , [mc| $hjs ++ sub $i : $mjs ++ sup #i : $tjs -> + tDiagIndex (SupSub i : hjs ++ mjs ++ tjs) |] + , [mc| _ -> js |] + ] -tProduct :: HasTensor a => (a -> a -> EvalM a) -> Tensor a -> Tensor a -> EvalM (Tensor a) +tProduct :: (a -> b -> EvalM c) -> Tensor a -> Tensor b -> EvalM (Tensor c) tProduct f (Tensor ns1 xs1 js1') (Tensor ns2 xs2 js2') = do - let k1 = fromIntegral $ length ns1 - length js1' - let js1 = js1' ++ map (DFscript 0) [1..k1] - let k2 = fromIntegral $ length ns2 - length js2' - let js2 = js2' ++ map (DFscript 0) [1..k2] + let js1 = js1' ++ complementWithDF ns1 js1' + let js2 = js2' ++ complementWithDF ns2 js2' let (cjs1, cjs2, tjs1, tjs2) = h js1 js2 let t1 = Tensor ns1 xs1 js1 let t2 = Tensor ns2 xs2 js2 case cjs1 of [] -> do - xs' <- V.fromList <$> mapM (\is -> do - let is1 = take (length ns1) is - let is2 = take (length ns2) (drop (length ns1) is) - x1 <- tIntRef is1 t1 >>= fromTensor - x2 <- tIntRef is2 t2 >>= fromTensor - f x1 x2) (enumTensorIndices (ns1 ++ ns2)) - tContract' (Tensor (ns1 ++ ns2) xs' (js1 ++ js2)) + xs' <- mapM (\is -> do let is1 = take (length ns1) is + let is2 = take (length ns2) (drop (length ns1) is) + x1 <- tIntRef1 is1 t1 + x2 <- tIntRef1 is2 t2 + f x1 x2) + (enumTensorIndices (ns1 ++ ns2)) + tContract' (Tensor (ns1 ++ ns2) (V.fromList xs') (js1 ++ js2)) _ -> do t1' <- tTranspose (cjs1 ++ tjs1) t1 t2' <- tTranspose (cjs2 ++ tjs2) t2 let (cns1, _) = splitAt (length cjs1) (tShape t1') rts' <- mapM (\is -> do rt1 <- tIntRef is t1' rt2 <- tIntRef is t2' - tProduct f rt1 rt2) (enumTensorIndices cns1) - let ret = Tensor (cns1 ++ tShape (head rts')) (V.concat (map tToVector rts')) (map toSupSubscript cjs1 ++ tIndex (head rts')) - tTranspose (uniq (map toSupSubscript cjs1 ++ tjs1 ++ tjs2)) ret + tProduct f rt1 rt2) + (enumTensorIndices cns1) + let ret = Tensor (cns1 ++ tShape (head rts')) (V.concat (map tToVector rts')) (map toSupSub cjs1 ++ tIndex (head rts')) + tTranspose (uniq (map toSupSub cjs1 ++ tjs1 ++ tjs2)) ret where h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue], [Index EgisonValue]) h js1 js2 = let cjs = filter (\j -> any (p j) js2) js1 in (cjs, map reverseIndex cjs, js1 \\ cjs, js2 \\ map reverseIndex cjs) p :: Index EgisonValue -> Index EgisonValue -> Bool - p (Superscript i) (Subscript j) = i == j - p (Subscript i) (Superscript j) = i == j - p _ _ = False + p (Sup i) (Sub j) = i == j + p (Sub i) (Sup j) = i == j + p _ _ = False uniq :: [Index EgisonValue] -> [Index EgisonValue] uniq [] = [] uniq (x:xs) = x:uniq (delete x xs) -tProduct f (Scalar x) (Tensor ns xs js) = do - xs' <- V.mapM (f x) xs - return $ Tensor ns xs' js -tProduct f (Tensor ns xs js) (Scalar x) = do - xs' <- V.mapM (`f` x) xs - return $ Tensor ns xs' js +tProduct f (Scalar x) t@Tensor{} = tMap (f x) t +tProduct f t@Tensor{} (Scalar x) = tMap (`f` x) t tProduct f (Scalar x1) (Scalar x2) = Scalar <$> f x1 x2 -tContract :: HasTensor a => Tensor a -> EvalM [Tensor a] +tContract :: Tensor a -> EvalM [Tensor a] tContract t = do t' <- tDiag t case t' of - (Tensor (n:_) _ (SupSubscript _ : _)) -> do + Tensor (n:_) _ (SupSub _ : _) -> do ts <- mapM (`tIntRef'` t') [1..n] - tss <- mapM toTensor ts >>= mapM tContract + tss <- mapM tContract ts return $ concat tss _ -> return [t'] --- TODO: refactor in PMOP -tContract' :: HasTensor a => Tensor a -> EvalM (Tensor a) +tContract' :: Tensor a -> EvalM (Tensor a) tContract' t@(Tensor ns _ js) = - case findPair p js of - Nothing -> return t - Just (m, n) -> do - let (hjs, mjs, tjs) = removePair (m,n) js - xs' <- mapM (\i -> tref (hjs ++ [Subscript (ScalarData (SingleTerm i []))] ++ mjs - ++ [Subscript (ScalarData (SingleTerm i []))] ++ tjs) t) - [1..(ns !! m)] - mapM toTensor xs' >>= tConcat (js !! m) >>= tTranspose (hjs ++ [js !! m] ++ mjs ++ tjs) >>= tContract' + match dfs js (List M.Something) + [ [mc| $hjs ++ $a : $mjs ++ ?(p a) : $tjs -> do + let m = fromIntegral (length hjs) + xs' <- mapM (\i -> tref (hjs ++ (Sub (ScalarData (SingleTerm i [])) : mjs) + ++ (Sub (ScalarData (SingleTerm i [])) : tjs)) t) + [1..(ns !! m)] + tConcat a xs' >>= tTranspose (hjs ++ a : mjs ++ tjs) >>= tContract' |] + , [mc| _ -> return t |] + ] where p :: Index EgisonValue -> Index EgisonValue -> Bool - p (Superscript i) (Superscript j) = i == j - p (Subscript i) (Subscript j) = i == j - p (DFscript i1 j1) (DFscript i2 j2) = (i1 == i2) && (j1 == j2) - p _ _ = False + p (Sup i) (Sup j) = i == j + p (Sub i) (Sub j) = i == j + p (DF i1 j1) (DF i2 j2) = (i1 == i2) && (j1 == j2) + p _ _ = False tContract' val = return val -tConcat :: HasTensor a => Index EgisonValue -> [Tensor a] -> EvalM (Tensor a) +tConcat :: Index EgisonValue -> [Tensor a] -> EvalM (Tensor a) tConcat s (Tensor ns@(0:_) _ js:_) = return $ Tensor (0:ns) V.empty (s:js) tConcat s ts@(Tensor ns _ js:_) = return $ Tensor (fromIntegral (length ts):ns) (V.concat (map tToVector ts)) (s:js) tConcat s ts = do ts' <- mapM getScalar ts return $ Tensor [fromIntegral (length ts)] (V.fromList ts') [s] -tConcat' :: HasTensor a => [Tensor a] -> EvalM (Tensor a) +tConcat' :: [Tensor a] -> EvalM (Tensor a) tConcat' (Tensor ns@(0:_) _ _ : _) = return $ Tensor (0:ns) V.empty [] tConcat' ts@(Tensor ns _ _ : _) = return $ Tensor (fromIntegral (length ts):ns) (V.concat (map tToVector ts)) [] tConcat' ts = do ts' <- mapM getScalar ts return $ Tensor [fromIntegral (length ts)] (V.fromList ts') [] - -- utility functions for tensors cdr :: [a] -> [a] @@ -413,37 +376,23 @@ split :: Integer -> V.Vector a -> [V.Vector a] split w xs - | V.null xs = [] - | otherwise = let (hs, ts) = V.splitAt (fromIntegral w) xs in - hs:split w ts + | V.null xs = [] + | otherwise = let (hs, ts) = V.splitAt (fromIntegral w) xs in + hs:split w ts getScalar :: Tensor a -> EvalM a getScalar (Scalar x) = return x getScalar _ = throwError $ Default "Inconsitent Tensor order" -findPair :: (a -> a -> Bool) -> [a] -> Maybe (Int, Int) -findPair p xs = findPair' 0 p xs - --- TODO: refactor in PMOP -findPair' :: Int -> (a -> a -> Bool) -> [a] -> Maybe (Int, Int) -findPair' _ _ [] = Nothing -findPair' m p (x:xs) = case findIndex (p x) xs of - Just i -> Just (m, m + i + 1) - Nothing -> findPair' (m + 1) p xs - --- TODO: refactor in PMOP -removePair :: (Int, Int) -> [a] -> ([a],[a],[a]) -removePair (m, n) xs = -- (0,1) [i i] - let (hms, tts) = splitAt n xs -- [i] [i] - ts = tail tts -- [] - (hs, tms) = splitAt m hms -- [] [i] - ms = tail tms -- [] - in (hs, ms, ts) -- [] [] [] +reverseIndex :: Index a -> Index a +reverseIndex (Sup i) = Sub i +reverseIndex (Sub i) = Sup i +reverseIndex x = x -reverseIndex :: Index EgisonValue -> Index EgisonValue -reverseIndex (Superscript i) = Subscript i -reverseIndex (Subscript i) = Superscript i +toSupSub :: Index a -> Index a +toSupSub (Sup i) = SupSub i +toSupSub (Sub i) = SupSub i -toSupSubscript :: Index EgisonValue -> Index EgisonValue -toSupSubscript (Superscript i) = SupSubscript i -toSupSubscript (Subscript i) = SupSubscript i +complementWithDF :: Shape -> [Index a] -> [Index a] +complementWithDF ns js' = map (DF 0) [1..k] + where k = fromIntegral $ length ns - length js' diff --git a/hs-src/Language/Egison/Types.hs b/hs-src/Language/Egison/Types.hs deleted file mode 100644 --- a/hs-src/Language/Egison/Types.hs +++ /dev/null @@ -1,115 +0,0 @@ -{- | -Module : Language.Egison.Types -Licence : MIT - -This module contains functions for dynamic type systems. --} - -module Language.Egison.Types - ( isBool - , isInteger - , isRational - , isSymbol - , isScalar - , isTensor - , isTensorWithIndex - , isBool' - , isInteger' - , isRational' - , isScalar' - , isFloat' - , isComplex' - , isTensor' - , isTensorWithIndex' - , isChar' - , isString' - , isCollection' - , isHash' - ) where - -import Language.Egison.Data -import Language.Egison.MathExpr - --- --- Typing --- - -isBool :: EgisonValue -> Bool -isBool (Bool _) = True -isBool _ = False - -isBool' :: PrimitiveFunc -isBool' (Value val) = return $ Value $ Bool $ isBool val - -isInteger :: EgisonValue -> Bool -isInteger (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = True -isInteger (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = True -isInteger _ = False - -isInteger' :: PrimitiveFunc -isInteger' (Value val) = return $ Value $ Bool $ isInteger val - -isRational :: EgisonValue -> Bool -isRational (ScalarData (Div (Plus []) (Plus [Term _ []]))) = True -isRational (ScalarData (Div (Plus [Term _ []]) (Plus [Term _ []]))) = True -isRational _ = False - -isRational' :: PrimitiveFunc -isRational' (Value val) = return $ Value $ Bool $ isRational val - -isSymbol :: EgisonValue -> Bool -isSymbol (ScalarData (Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []]))) = True -isSymbol _ = False - -isScalar :: EgisonValue -> Bool -isScalar (ScalarData _) = True -isScalar _ = False - -isScalar' :: PrimitiveFunc -isScalar' (Value (ScalarData _)) = return $ Value $ Bool True -isScalar' _ = return $ Value $ Bool False - -isTensor :: EgisonValue -> Bool -isTensor (TensorData _) = True -isTensor _ = False - -isTensor' :: PrimitiveFunc -isTensor' (Value (TensorData _)) = return $ Value $ Bool True -isTensor' (Intermediate (ITensor _)) = return $ Value $ Bool True -isTensor' _ = return $ Value $ Bool False - -isTensorWithIndex :: EgisonValue -> Bool -isTensorWithIndex (TensorData (Tensor _ _ (_:_))) = True -isTensorWithIndex _ = False - -isTensorWithIndex' :: PrimitiveFunc -isTensorWithIndex' (Value val) = return $ Value $ Bool $ isTensorWithIndex val -isTensorWithIndex' _ = return $ Value $ Bool False - -isFloat' :: PrimitiveFunc -isFloat' (Value (Float _)) = return $ Value $ Bool True -isFloat' _ = return $ Value $ Bool False - -isComplex' :: PrimitiveFunc -isComplex' (Value (Float _)) = return $ Value $ Bool True -isComplex' _ = return $ Value $ Bool False - -isChar' :: PrimitiveFunc -isChar' (Value (Char _)) = return $ Value $ Bool True -isChar' _ = return $ Value $ Bool False - -isString' :: PrimitiveFunc -isString' (Value (String _)) = return $ Value $ Bool True -isString' _ = return $ Value $ Bool False - -isCollection' :: PrimitiveFunc -isCollection' (Value (Collection _)) = return $ Value $ Bool True -isCollection' (Intermediate (ICollection _)) = return $ Value $ Bool True -isCollection' _ = return $ Value $ Bool False - -isHash' :: PrimitiveFunc -isHash' (Value (IntHash _)) = return $ Value $ Bool True -isHash' (Value (StrHash _)) = return $ Value $ Bool True -isHash' (Intermediate (IIntHash _)) = return $ Value $ Bool True -isHash' (Intermediate (IStrHash _)) = return $ Value $ Bool True -isHash' _ = return $ Value $ Bool False 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 @@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} module Main where import Control.Arrow ((***)) -import Data.List (find) import Data.Maybe (fromJust) import Data.Text.Prettyprint.Doc.Render.Text (putDoc) import System.Environment (getArgs) @@ -13,58 +13,85 @@ import Language.Egison.Parser.SExpr import Language.Egison.Pretty + +exprInfix :: [(String, Op)] +exprInfix = + [ ("**", Op "^" 8 InfixL False) + , ("**'", Op "^'" 8 InfixL False) + , ("*", Op "*" 7 InfixL False) + , ("/", Op "/" 7 InfixL False) + , ("*'", Op "*'" 7 InfixL False) + , ("/'", Op "/'" 7 InfixL False) + , (".", Op "." 7 InfixL False) -- tensor multiplication + , (".'", Op ".'" 7 InfixL False) -- tensor multiplication + , ("remainder", Op "%" 7 InfixL False) -- primitive function + , ("+", Op "+" 6 InfixL False) + , ("-", Op "-" 6 InfixL False) + , ("+'", Op "+'" 6 InfixL False) + , ("-'", Op "-'" 6 InfixL False) + , ("append", Op "++" 5 InfixR False) + , ("cons", Op "::" 5 InfixR False) + , ("equal", Op "=" 4 InfixL False) -- primitive function + , ("lte", Op "<=" 4 InfixL False) -- primitive function + , ("gte", Op ">=" 4 InfixL False) -- primitive function + , ("lt", Op "<" 4 InfixL False) -- primitive function + , ("gt", Op ">" 4 InfixL False) -- primitive function + , ("&&", Op "&&" 3 InfixR False) + , ("and", Op "&&" 3 InfixR False) + , ("||", Op "||" 2 InfixR False) + , ("or", Op "||" 2 InfixR False) + , ("apply", Op "$" 0 InfixR False) + ] + +patternInfix :: [(String, Op)] +patternInfix = + [ ("^", Op "^" 8 InfixL False) -- PowerPat + , ("*", Op "*" 7 InfixL False) -- MultPat + , ("div", Op "/" 7 InfixL False) -- DivPat + , ("+", Op "+" 6 InfixL False) -- PlusPat + , ("cons", Op "::" 5 InfixR False) + , ("join", Op "++" 5 InfixR False) + , ("&", Op "&" 3 InfixR False) + , ("|", Op "|" 2 InfixR False) + ] + +lookupVarExprInfix :: String -> Maybe Op +lookupVarExprInfix x = lookup x exprInfix + class SyntaxElement a where toNonS :: a -> a -instance SyntaxElement EgisonTopExpr where +instance SyntaxElement TopExpr where toNonS (Define x y) = Define (toNonS x) (toNonS y) - toNonS (Redefine _ _) = error "Not supported" toNonS (Test x) = Test (toNonS x) toNonS (Execute x) = Execute (toNonS x) toNonS x = x -instance SyntaxElement EgisonExpr where - toNonS (IntegerExpr x) = IntegerExpr x - toNonS (VarExpr v) | any (\op -> func op == prettyS v) reservedExprInfix = +instance SyntaxElement Expr where + toNonS (VarExpr (lookupVarExprInfix -> Just op)) = SectionExpr op Nothing Nothing - where - op = fromJust $ find (\op -> func op == prettyS v) reservedExprInfix - toNonS (VarExpr x) = VarExpr (toNonS x) + toNonS (VarExpr x) = VarExpr x toNonS (IndexedExpr b x ys) = IndexedExpr b (toNonS x) (map toNonS ys) toNonS (SubrefsExpr b x y) = SubrefsExpr b (toNonS x) (toNonS y) toNonS (SuprefsExpr b x y) = SuprefsExpr b (toNonS x) (toNonS y) toNonS (UserrefsExpr b x y) = UserrefsExpr b (toNonS x) (toNonS y) - toNonS (PowerExpr x y) = InfixExpr powerOp (toNonS x) (toNonS y) - where powerOp = fromJust $ find (\op -> repr op == "^") reservedExprInfix - toNonS (InductiveDataExpr x ys) = InductiveDataExpr x (map toNonS ys) toNonS (TupleExpr xs) = TupleExpr (map toNonS xs) - toNonS (CollectionExpr xs) - | all isElementExpr xs = CollectionExpr (map toNonS xs) - | otherwise = f xs - where - isElementExpr :: InnerExpr -> Bool - isElementExpr ElementExpr{} = True - isElementExpr _ = False - f [] = CollectionExpr [] - f [ElementExpr x] = CollectionExpr [ElementExpr (toNonS x)] - f [SubCollectionExpr x] = toNonS x - f (ElementExpr x : xs) = InfixExpr cons (toNonS x) (f xs) - f (SubCollectionExpr x : xs) = InfixExpr append (toNonS x) (f xs) - cons = fromJust $ find (\op -> repr op == "::") reservedExprInfix - append = fromJust $ find (\op -> repr op == "++") reservedExprInfix + toNonS (CollectionExpr xs) = CollectionExpr (map toNonS xs) + toNonS (ConsExpr x xs) = InfixExpr cons (toNonS x) (toNonS xs) + where cons = fromJust $ lookup "cons" exprInfix + toNonS (JoinExpr x xs) = InfixExpr append (toNonS x) (toNonS xs) + where append = fromJust $ lookup "append" exprInfix toNonS (HashExpr xs) = HashExpr (map (toNonS *** toNonS) xs) toNonS (VectorExpr xs) = VectorExpr (map toNonS xs) - toNonS (LambdaExpr xs e) = LambdaExpr xs (toNonS e) + toNonS (LambdaExpr xs e) = LambdaExpr xs (toNonS e) toNonS (MemoizedLambdaExpr xs e) = MemoizedLambdaExpr xs (toNonS e) toNonS (CambdaExpr x e) = CambdaExpr x (toNonS e) toNonS (PatternFunctionExpr xs p) = PatternFunctionExpr xs (toNonS p) toNonS (IfExpr x y z) = IfExpr (toNonS x) (toNonS y) (toNonS z) toNonS (LetRecExpr xs y) = LetRecExpr (map toNonS xs) (toNonS y) - toNonS (LetExpr xs y) = LetRecExpr (map toNonS xs) (toNonS y) - toNonS (LetStarExpr xs y) = LetRecExpr (map toNonS xs) (toNonS y) toNonS (WithSymbolsExpr xs y) = WithSymbolsExpr xs (toNonS y) toNonS (MatchExpr pmmode m p xs) = MatchExpr pmmode (toNonS m) (toNonS p) (map toNonS xs) @@ -78,44 +105,31 @@ toNonS (QuoteExpr x) = QuoteExpr (toNonS x) toNonS (QuoteSymbolExpr x) = QuoteSymbolExpr (toNonS x) - toNonS (WedgeApplyExpr (VarExpr f) (TupleExpr (y:ys))) - | any (\op -> func op == prettyS f) reservedExprInfix = - optimize $ foldl (\acc x -> InfixExpr op acc (toNonS x)) (toNonS y) ys + toNonS (WedgeApplyExpr (VarExpr (lookupVarExprInfix -> Just op)) (y:ys)) = + optimize $ foldl (\acc x -> InfixExpr op' acc (toNonS x)) (toNonS y) ys where - op = - let op' = fromJust $ find (\op -> func op == prettyS f) reservedExprInfix - in op' { isWedge = True } + op' = op { isWedge = True } - optimize (InfixExpr (Infix { repr = "*" }) (IntegerExpr (-1)) e2) = + optimize (InfixExpr Op{ repr = "*" } (ConstantExpr (IntegerExpr (-1))) e2) = PrefixExpr "-" (optimize e2) optimize (InfixExpr op e1 e2) = InfixExpr op (optimize e1) (optimize e2) optimize e = e - toNonS (WedgeApplyExpr x y) = WedgeApplyExpr (toNonS x) (toNonS y) + toNonS (WedgeApplyExpr x ys) = WedgeApplyExpr (toNonS x) (map toNonS ys) toNonS (DoExpr xs y) = DoExpr (map toNonS xs) (toNonS y) - toNonS (IoExpr x) = IoExpr (toNonS x) toNonS (SeqExpr e1 e2) = SeqExpr (toNonS e1) (toNonS e2) - toNonS (ApplyExpr (VarExpr f) (TupleExpr (y:ys))) | prettyS f == "and" = - foldl (\acc x -> InfixExpr op acc (toNonS x)) (toNonS y) ys - where op = fromJust $ find (\op -> repr op == "&&") reservedExprInfix - toNonS (ApplyExpr (VarExpr f) (TupleExpr (y:ys))) | prettyS f == "or" = - foldl (\acc x -> InfixExpr op acc (toNonS x)) (toNonS y) ys - where op = fromJust $ find (\op -> repr op == "||") reservedExprInfix - toNonS (ApplyExpr (VarExpr f) (TupleExpr (y:ys))) - | any (\op -> func op == prettyS f) reservedExprInfix = - optimize $ foldl (\acc x -> InfixExpr op acc (toNonS x)) (toNonS y) ys + toNonS (ApplyExpr (VarExpr (lookupVarExprInfix -> Just op)) (y:ys)) = + optimize $ foldl (\acc x -> InfixExpr op acc (toNonS x)) (toNonS y) ys where - op = fromJust $ find (\op -> func op == prettyS f) reservedExprInfix - - optimize (InfixExpr (Infix { repr = "*" }) (IntegerExpr (-1)) e2) = + optimize (InfixExpr Op{ repr = "*" } (ConstantExpr (IntegerExpr (-1))) e2) = PrefixExpr "-" (optimize e2) optimize (InfixExpr op e1 e2) = InfixExpr op (optimize e1) (optimize e2) optimize e = e - toNonS (ApplyExpr x y) = ApplyExpr (toNonS x) (toNonS y) + toNonS (ApplyExpr x ys) = ApplyExpr (toNonS x) (map toNonS ys) toNonS (CApplyExpr e1 e2) = CApplyExpr (toNonS e1) (toNonS e2) toNonS (AnonParamFuncExpr n e) = case AnonParamFuncExpr n (toNonS e) of @@ -138,44 +152,26 @@ toNonS x = x -instance SyntaxElement EgisonPattern where +instance SyntaxElement Pattern where toNonS (ValuePat e) = ValuePat (toNonS e) toNonS (PredPat e) = PredPat (toNonS e) toNonS (IndexedPat p es) = IndexedPat (toNonS p) (map toNonS es) toNonS (LetPat binds pat) = LetPat (map toNonS binds) (toNonS pat) toNonS (InfixPat op p1 p2) = InfixPat op (toNonS p1) (toNonS p2) toNonS (NotPat p) = NotPat (toNonS p) - toNonS (AndPat []) = error "Not supported: empty and pattern" - toNonS (AndPat ps) = toNonS (foldr1 (\p acc -> InfixPat op p acc) ps) - where op = fromJust $ find (\op -> repr op == "&") reservedPatternInfix - toNonS (OrPat []) = error "Not supported: empty or pattern" - toNonS (OrPat ps) = toNonS (foldr1 (\p acc -> InfixPat op p acc) ps) - where op = fromJust $ find (\op -> repr op == "|") reservedPatternInfix + toNonS (AndPat p1 p2) = InfixPat op (toNonS p1) (toNonS p2) + where op = fromJust $ lookup "&" patternInfix + toNonS (OrPat p1 p2) = InfixPat op (toNonS p1) (toNonS p2) + where op = fromJust $ lookup "|" patternInfix toNonS ForallPat{} = error "Not supported: forall pattern" toNonS (TuplePat ps) = TuplePat (map toNonS ps) - toNonS (InductivePat name [p1, p2]) - | any (\op -> func op == name) reservedPatternInfix = - InfixPat op (toNonS p1) (toNonS p2) - where op = fromJust $ find (\op -> func op == name) reservedPatternInfix + toNonS (InductivePat ((`lookup` patternInfix) -> Just op) [p1, p2]) = + InfixPat op (toNonS p1) (toNonS p2) toNonS (InductivePat name ps) = InductivePat name (map toNonS ps) toNonS (LoopPat i range p1 p2) = LoopPat i (toNonS range) (toNonS p1) (toNonS p2) toNonS (PApplyPat e p) = PApplyPat (toNonS e) (map toNonS p) toNonS (SeqConsPat p1 p2) = SeqConsPat (toNonS p1) (toNonS p2) toNonS (DApplyPat p ps) = DApplyPat (toNonS p) (map toNonS ps) - toNonS (DivPat p1 p2) = InfixPat op (toNonS p1) (toNonS p2) - where op = fromJust $ find (\op -> repr op == "/") reservedPatternInfix - toNonS (PlusPat []) = InductivePat "plus" [] - toNonS (PlusPat [p]) = InductivePat "plus" [toNonS p] - toNonS (PlusPat (p:ps)) = - foldl (\acc x -> InfixPat op acc (toNonS x)) (toNonS p) ps - where op = fromJust $ find (\op -> repr op == "+") reservedPatternInfix - toNonS (MultPat []) = InductivePat "mult" [] - toNonS (MultPat [p]) = InductivePat "mult" [toNonS p] - toNonS (MultPat (p:ps)) = - foldl (\acc x -> InfixPat op acc (toNonS x)) (toNonS p) ps - where op = fromJust $ find (\op -> repr op == "*") reservedPatternInfix - toNonS (PowerPat p1 p2) = InfixPat op (toNonS p1) (toNonS p2) - where op = fromJust $ find (\op -> repr op == "^") reservedPatternInfix toNonS p = p instance SyntaxElement PrimitivePatPattern where @@ -188,21 +184,17 @@ 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 (PDConstantPat e) = PDConstantPat (toNonS e) toNonS pd = pd instance SyntaxElement LoopRange where toNonS (LoopRange e1 e2 p) = LoopRange (toNonS e1) (toNonS e2) (toNonS p) -instance SyntaxElement a => SyntaxElement (Index a) where +instance SyntaxElement a => SyntaxElement (IndexExpr a) where toNonS script = toNonS <$> script -instance SyntaxElement InnerExpr where - toNonS (ElementExpr x) = ElementExpr (toNonS x) - toNonS (SubCollectionExpr _) = error "Not supported: SubCollectionExpr" - instance SyntaxElement BindingExpr where - toNonS (vars, x) = (map toNonS vars, toNonS x) + toNonS (Bind pdp x) = Bind (toNonS pdp) (toNonS x) + toNonS (BindWithIndices var x) = BindWithIndices var (toNonS x) instance SyntaxElement MatchClause where toNonS (pat, body) = (toNonS pat, toNonS body) @@ -210,9 +202,8 @@ instance SyntaxElement PatternDef where toNonS (x, y, zs) = (toNonS x, toNonS y, map (\(z, w) -> (toNonS z, toNonS w)) zs) -instance SyntaxElement Var where +instance SyntaxElement VarWithIndices where toNonS = id - main :: IO () main = do diff --git a/lib/core/assoc.egi b/lib/core/assoc.egi --- a/lib/core/assoc.egi +++ b/lib/core/assoc.egi @@ -4,14 +4,14 @@ -- -- -toAssoc xs := +def toAssoc xs := match xs as list something with | [] -> [] | $x :: (loop $i (2, $n) (#x :: ...) (!(#x :: _) & $rs)) -> (x, n) :: toAssoc rs -fromAssoc xs := +def fromAssoc xs := match xs as list (something, integer) with | [] -> [] | ($x, $n) :: $rs -> take n (repeat1 x) ++ fromAssoc rs @@ -19,7 +19,7 @@ -- -- Assoc List -- -assocList a := +def assocList a := matcher | [] as () with | [] -> [()] @@ -49,7 +49,7 @@ -- -- Assoc Multiset -- -assocMultiset a := +def assocMultiset a := matcher | [] as () with | [] -> [()] @@ -85,10 +85,10 @@ | $ as (something) with | $tgt -> [tgt] -AC.intersect xs ys := +def AC.intersect xs ys := matchAll (xs, ys) as (assocMultiset something, assocMultiset something) with | (ncons $x $m _, ncons #x $n _) -> (x, min m n) -AC.intersectAs a xs ys := +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) diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -4,56 +4,60 @@ -- -- -eq := +def eq := matcher | #$val as () with | $tgt -> if val = tgt then [()] else [] | $ as (something) with | $tgt -> [tgt] -bool := eq -char := eq -integer := eq -float := eq +def bool := eq +def char := eq +def integer := eq +def float := eq -- -- Utility -- -id := 1#%1 +def id := 1#%1 -fst := 2#%1 +def fst (x, y) := x +def snd (x, y) := y -snd := 2#%2 +infixr expression 0 $ -apply f x := f x +def ($) f x := f x -compose f g := \x -> g (f x) +def compose f g := \x -> g (f x) -flip fn := \$x $y -> fn y x +def flip fn := \$x $y -> fn y x -eqAs a x y := +def eqAs a x y := match x as a with | #y -> True | _ -> False +def curry f x y := f (x, y) +def uncurry f (x, y) := f x y + -- -- Boolean -- -(&&) b1 b2 := if b1 then b2 else False -(||) b1 b2 := if b1 then True else b2 +infixr expression 3 && +infixr expression 2 || -not b := - match b as bool with - | #True -> False - | #False -> True +def (&&) b1 b2 := if b1 then b2 else False +def (||) b1 b2 := if b1 then True else b2 +def not b := if b then False else True + -- -- Unordered Pair -- -unorderedPair m := +def unorderedPair m := matcher | ($, $) as (m, m) with | ($x, $y) -> [(x, y), (y, x)] diff --git a/lib/core/collection.egi b/lib/core/collection.egi --- a/lib/core/collection.egi +++ b/lib/core/collection.egi @@ -7,7 +7,7 @@ -- -- List -- -list a := +def list a := matcher | [] as () with | [] -> [()] @@ -18,6 +18,8 @@ | snoc $ $ as (a, list a) with | snoc $xs $x -> [(x, xs)] | _ -> [] + | _ ++ $ :: _ as (a) with + | $tgt -> tgt | _ ++ $ as (list a) with | $tgt -> matchAll tgt as list a with @@ -41,7 +43,7 @@ | $ as (something) with | $tgt -> [tgt] -sortedList a := +def sortedList a := matcher | [] as () with | [] -> [()] @@ -69,53 +71,43 @@ -- -- Accessors -- -nth n xs := +def nth n xs := match xs as list something with | loop $i (1, n - 1, _) (_ :: ...) ($x :: _) -> x -takeAndDrop n xs := +def takeAndDrop n xs := match xs as list something with | loop $i (1, n, _) ($a_i :: ...) $rs -> (map (\i -> a_i) [1..n], rs) -take n xs := +def take n xs := if n = 0 then [] else match xs as list something with | $x :: $xs -> x :: take (n - 1) xs | [] -> [] -drop n xs := +def drop n xs := if n = 0 then xs else match xs as list something with | _ :: $xs -> drop (n - 1) xs | [] -> [] -takeWhile pred xs := +def takeWhile pred xs := match xs as list something with | [] -> [] | $x :: $rs -> if pred x then x :: takeWhile pred rs else [] -takeWhileBy pred xs := +def takeWhileBy pred xs := match xs as list something with | [] -> [] | $x :: $rs -> if pred x then x :: takeWhileBy pred rs else [x] -taileUntil pred xs := - match xs as list something with - | [] -> [] - | $x :: $rs -> if not (pred x) then x :: takeUntil pred rs else [] - -takeUntilBy pred xs := - match xs as list something with - | [] -> [] - | $x :: $rs -> if not (pred x) then x :: takeUntilBy pred rs else [x] - -dropWhile pred xs := +def dropWhile pred xs := match xs as list something with | [] -> [] | $x :: $rs -> if pred x then dropWhile pred rs else xs @@ -123,27 +115,27 @@ -- -- head, tail, uncons, unsnoc -- -head xs := +def head xs := match xs as list something with | $x :: _ -> x -tail xs := +def tail xs := match xs as list something with | _ :: $ys -> ys -last xs := +def last xs := match xs as list something with | snoc $x _ -> x -init xs := +def init xs := match xs as list something with | snoc _ $ys -> ys -uncons xs := +def uncons xs := match xs as list something with | $x :: $ys -> (x, ys) -unsnoc xs := +def unsnoc xs := match xs as list something with | snoc $x $ys -> (ys, x) @@ -151,32 +143,32 @@ -- -- list functions -- -isEmpty xs := +def isEmpty xs := match xs as list something with | [] -> True | _ -> False -length xs := foldl 2#(%1 + 1) 0 xs +def length xs := foldl 2#(%1 + 1) 0 xs -map fn xs := +def map fn xs := match xs as list something with | [] -> [] | $x :: $rs -> fn x :: map fn rs -map2 fn xs ys := +def map2 fn xs ys := match (xs, ys) as (list something, list something) with | ([], _) -> [] | (_, []) -> [] | ($x :: $xs2, $y :: $ys2) -> fn x y :: map2 fn xs2 ys2 -map3 fn xs ys zs := +def map3 fn xs ys zs := match (xs, ys, zs) as (list something, list something, list something) with | ([], _, _) -> [] | (_, [], _) -> [] | (_, _, []) -> [] | ($x :: $xs2, $y :: $ys2, $z :: $zs2) -> fn x y z :: map3 fn xs2 ys2 zs2 -map4 fn xs ys zs ws := +def map4 fn xs ys zs ws := match (xs, ys, zs, ws) as (list something, list something, list something, list something) with | ([], _, _, _) -> [] @@ -186,42 +178,42 @@ | ($x :: $xs2, $y :: $ys2, $z :: $zs2, $w :: $ws2) -> fn x y z w :: map4 fn xs2 ys2 zs2 ws2 -filter pred xs := foldr (\%y %ys -> if pred y then y :: ys else ys) [] xs +def filter pred xs := foldr (\%y %ys -> if pred y then y :: ys else ys) [] xs -partition pred xs := (filter pred xs, filter 1#(not (pred %1)) xs) +def partition pred xs := (filter pred xs, filter 1#(not (pred %1)) xs) -zip xs ys := map2 (\x y -> (x, y)) xs ys +def zip xs ys := map2 (\x y -> (x, y)) xs ys -zip3 xs ys zs := map3 (\x y z -> (x, y, z)) xs ys zs +def zip3 xs ys zs := map3 (\x y z -> (x, y, z)) xs ys zs -zip4 xs ys zs ws := map4 (\x y z w -> (x, y, z, w)) xs ys zs ws +def zip4 xs ys zs ws := map4 (\x y z w -> (x, y, z, w)) xs ys zs ws -lookup k ls := +def lookup k ls := match ls as list (something, something) with | _ ++ (#k, $x) :: _ -> x -foldr fn %init %ls := +def foldr fn %init %ls := match ls as list something with | [] -> init | $x :: $xs -> fn x (foldr fn init xs) -foldl fn %init %ls := +def foldl fn %init %ls := match ls as list something with | [] -> init | $x :: $xs -> let z := fn init x in seq z (foldl fn z xs) -foldl1 fn %ls := foldl fn (head ls) (tail ls) +def foldl1 fn %ls := foldl fn (head ls) (tail ls) -reduce fn %ls := foldl fn (head ls) (tail ls) +def reduce fn %ls := foldl fn (head ls) (tail ls) -scanl fn %init %ls := +def scanl fn %init %ls := init :: (match ls as list something with | [] -> [] | $x :: $xs -> scanl fn (fn init x) xs) -iterate fn %x := +def iterate fn %x := let nx1 := fn x nx2 := fn nx1 nx3 := fn nx2 @@ -229,7 +221,7 @@ nx5 := fn nx4 in x :: nx1 :: nx2 :: nx3 :: nx4 :: iterate fn nx5 -repeatedSquaring fn %x n := +def repeatedSquaring fn %x n := match n as integer with | #1 -> x | ?isEven -> @@ -239,63 +231,63 @@ let y := repeatedSquaring fn x (quotient n 2) in fn (fn y y) x -append xs ys := xs ++ ys - -concat xss := foldr (\%xs %rs -> xs ++ rs) [] xss +def concat xss := foldr (\%xs %rs -> xs ++ rs) [] xss -reverse xs := +def reverse xs := match xs as list something with | [] -> [] | snoc $x $rs -> x :: reverse rs -intersperse sep ws := +def intersperse sep ws := match ws as list something with | [] -> [] | $w :: $rs -> foldl (\s1 s2 -> s1 ++ [sep, s2]) [w] rs -intercalate := compose intersperse concat +def intercalate sep ws := concat (intersperse sep ws) -split sep ls := +def split sep ls := match ls as list something with | $xs ++ #sep ++ $rs -> xs :: split sep rs | _ -> [ls] -splitAs a sep ls := +def splitAs a sep ls := match ls as list a with | $xs ++ #sep ++ $rs -> xs :: splitAs a sep rs | _ -> [ls] -findCycle xs := +def splitAt n ls := (take n ls, drop n ls) + +def findCycle xs := head (matchAll xs as list something with | $ys ++ (_ :: _ & $cs) ++ #cs ++ _ -> (ys, cs)) -repeat %xs := xs ++ repeat xs +def repeat %xs := xs ++ repeat xs -repeat1 %x := x :: repeat1 x +def repeat1 %x := x :: repeat1 x -- -- Others -- -all pred xs := +def all pred xs := match xs as list something with | [] -> True | $x :: $rs -> if pred x then all pred rs else False -any pred xs := +def any pred xs := match xs as list something with | [] -> False | $x :: $rs -> if pred x then True else any pred rs -from s := +def from s := [s, s + 1, s + 2, s + 3, s + 4, s + 5, s + 6, s + 7, s + 8, s + 9, s + 10] ++ from (s + 11) -- Note. `between` is used in the definition of the list matcher. -between s e := +def between s e := if s = e then [s] else if s < e then s :: between (s + 1) e else [] -L./ xs ys := +def L./ xs ys := if length xs < length ys then ([], xs) else match (ys, xs) as (list mathExpr, list mathExpr) with @@ -304,14 +296,14 @@ (map2 (-) (take (length yrs) xrs) - (map 1#(%1 * (x / y)) yrs) ++ drop (length yrs) xrs) + (map (* (x / y)) yrs) ++ drop (length yrs) xrs) ys in (x / y :: zs, rs) -- -- Multiset -- -multiset a := +def multiset a := matcher | [] as () with | [] -> [()] @@ -348,77 +340,77 @@ -- -- multiset operation -- -deleteFirst %x xs := +def deleteFirst %x xs := match xs as list something with | [] -> [] | #x :: $rs -> rs | $y :: $rs -> y :: deleteFirst x rs -deleteFirstAs a %x xs := +def deleteFirstAs a %x xs := match xs as list a with | [] -> [] | #x :: $rs -> rs | $y :: $rs -> y :: deleteFirstAs a x rs -delete x xs := +def delete x xs := match xs as list something with | [] -> [] | $hs ++ #x :: $ts -> hs ++ delete x ts | _ -> xs -deleteAs a x xs := +def deleteAs a x xs := match xs as list a with | [] -> [] | $hs ++ #x :: $ts -> hs ++ deleteAs a x ts | _ -> xs -difference xs ys := +def difference xs ys := match ys as list something with | [] -> xs | $y :: $rs -> difference (deleteFirst y xs) rs -differenceAs a xs ys := +def differenceAs a xs ys := match ys as list a with | [] -> xs | $y :: $rs -> differenceAs a (deleteFirstAs a y xs) rs -include xs ys := +def include xs ys := match ys as list something with | [] -> True | $y :: $rs -> if member y xs then include (deleteFirst y xs) rs else False -includeAs a xs ys := +def includeAs a xs ys := match ys as list a with | [] -> True | $y :: $rs -> if memberAs a y xs then includeAs a (deleteFirst y xs) rs else False -union xs ys := +def union xs ys := xs ++ (matchAll (ys, xs) as (multiset something, multiset something) with | ($y :: _, !(#y :: _)) -> y) -unionAs a xs ys := +def unionAs a xs ys := xs ++ (matchAll (ys, xs) as (multiset a, multiset a) with | ($y :: _, !(#y :: _)) -> y) -intersect xs ys := +def intersect xs ys := matchAll (xs, ys) as (multiset something, multiset something) with | ($x :: _, #x :: _) -> x -intersectAs a xs ys := +def intersectAs a xs ys := matchAll (xs, ys) as (multiset a, multiset a) with | ($x :: _, #x :: _) -> x -- -- Simple predicate -- -member x ys := +def member x ys := match ys as list something with | _ ++ #x :: _ -> True | _ -> False -memberAs a x ys := +def memberAs a x ys := match ys as list a with | _ ++ #x :: _ -> True | _ -> False @@ -426,41 +418,29 @@ -- -- Counting -- -count x xs := - foldl - (\match as (something, something) with - | ($r, #x) -> r + 1 - | ($r, $y) -> r) - 0 - xs +def count x xs := + foldl (\acc y -> if x = y then acc + 1 else acc) 0 xs -countAs a x xs := - foldl - (\match as (a, a) with - | ($r, #x) -> r + 1 - | ($r, $y) -> r) - 0 - xs +def countAs a x xs := + foldl (\acc y -> if eqAs a x y then acc + 1 else acc) 0 xs -frequency xs := - let us := unique xs - in map (\u -> (u, count u xs)) us +def frequency xs := + map (\u -> (u, count u xs)) (unique xs) -frequencyAs a xs := - let us := uniqueAs a xs - in map (\u -> (u, countAs a u xs)) us +def frequencyAs a xs := + map (\u -> (u, countAs a u xs)) (uniqueAs a xs) -- -- Index -- -elemIndices x xs := +def elemIndices x xs := matchAll xs as list something with | $hs ++ #x :: _ -> 1 + length hs -- -- Set -- -set a := +def set a := matcher | [] as () with | [] -> [()] @@ -493,20 +473,20 @@ -- -- set operation -- -add x xs := if member x xs then xs else xs ++ [x] +def add x xs := if member x xs then xs else xs ++ [x] -addAs a x xs := if memberAs a x xs then xs else xs ++ [x] +def addAs a x xs := if memberAs a x xs then xs else xs ++ [x] -fastUnique xs := +def fastUnique xs := matchAll sort xs as list something with | _ ++ $x :: !(#x :: _) -> x -unique xs := +def unique xs := reverse (matchAll reverse xs as list something with | _ ++ $x :: !(_ ++ #x :: _) -> x) -uniqueAs a xs := loopFn xs [] +def uniqueAs a xs := loopFn xs [] where loopFn xs ys := match (xs, ys) as (list a, multiset a) with diff --git a/lib/core/io.egi b/lib/core/io.egi --- a/lib/core/io.egi +++ b/lib/core/io.egi @@ -7,22 +7,22 @@ -- -- IO -- -print x := +def print x := do write x write "\n" flush () -printToPort port x := +def printToPort port x := do writeToPort port x writeToPort port "\n" -display x := +def display x := do write x flush () -displayToPort port x := do writeToPort port x +def displayToPort port x := do writeToPort port x -eachLine proc := +def eachLine proc := do let eof := isEof () if eof then return () @@ -30,7 +30,7 @@ proc line eachLine proc -eachLineFromPort port proc := +def eachLineFromPort port proc := do let eof := isEofPort port if eof then return () @@ -38,7 +38,7 @@ proc line eachLineFromPort port proc -eachFile files proc := +def eachFile files proc := match files as list string with | [] -> return () | $file :: $rest -> @@ -50,7 +50,7 @@ -- -- Collection -- -each proc xs := +def each proc xs := match xs as list something with | [] -> do return () | $x :: $rs -> @@ -60,11 +60,11 @@ -- -- Debug -- -debug %expr := - io do print (show expr) - return expr +def debug %expr := + io $ do print (show expr) + return expr -debug2 %msg %expr := - io do display msg - print (show expr) - return expr +def debug2 %msg %expr := + io $ do display msg + print (show expr) + return expr diff --git a/lib/core/maybe.egi b/lib/core/maybe.egi --- a/lib/core/maybe.egi +++ b/lib/core/maybe.egi @@ -4,7 +4,7 @@ -- -- -maybe a := +def maybe a := matcher | nothing as () with | Nothing -> [()] diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -7,7 +7,7 @@ -- -- Natural Numbers -- -nat := +def nat := matcher | o as () with | 0 -> [()] @@ -22,7 +22,7 @@ | $ as (something) with | $tgt -> [tgt] -nats := +def nats := [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, @@ -35,30 +35,27 @@ 91, 92, 93, 94, 95, 96, 97, 98, 99, 100] ++ map (+ 100) nats -nats0 := 0 :: nats - -odds := 1 :: map (+ 2) odds +def nats0 := 0 :: nats -evens := 2 :: map (+ 2) evens +def odds := 1 :: map (+ 2) odds +def evens := 2 :: map (+ 2) evens -fibs := [1, 1] ++ map2 (+) fibs (tail fibs) +def fibs := [1, 1] ++ map2 (+) fibs (tail fibs) -isPrime := - \match as integer with - | ?(< 2) -> False - | $n -> n = findFactor n +def isPrime n := + if n < 2 then False else n = findFactor n -primes := 2 :: filter isPrime (drop 2 nats) +def primes := 2 :: filter isPrime (drop 2 nats) -divisor n d := 0 = n % d +def divisor n d := 0 = n % d -findFactor := +def findFactor := memoizedLambda n -> match takeWhile (<= floor (sqrt (itof n))) primes as list integer with - | _ ++ (?1#(divisor n %1) & $x) :: _ -> x + | _ ++ (?(divisor n) & $x) :: _ -> x | _ -> n -primeFactorization := +def primeFactorization := \match as integer with | #1 -> [] | ?(< 0) & $n -> (-1) :: primeFactorization (neg n) @@ -66,19 +63,18 @@ let p := findFactor n in p :: primeFactorization (quotient n p) -pF := primeFactorization - -isEven n := 0 = modulo n 2 +def pF := primeFactorization -isOdd n := 1 = modulo n 2 +def isEven n := 0 = modulo n 2 +def isOdd n := 1 = modulo n 2 -fact n := foldl (*) 1 [1..n] +def fact n := foldl (*) 1 [1..n] -perm n r := foldl (*) 1 [(n - (r - 1))..n] +def perm n r := foldl (*) 1 [(n - (r - 1))..n] -comb n r := perm n r / fact r +def comb n r := perm n r / fact r -nAdic n x := +def nAdic n x := if x = 0 then [] else let q := quotient x n @@ -88,7 +84,7 @@ -- -- Integers -- -mod m := +def mod m := matcher | #$n as () with | $tgt -> if modulo tgt m = modulo n m then [()] else [] @@ -98,24 +94,24 @@ -- -- Floats -- -exp2 x y := exp (log x * y) +def exp2 x y := exp (log x * y) -- -- Decimal Fractions -- -rtodHelper m n := +def rtodHelper m n := let q := quotient (m * 10) n r := m * 10 % n in (q, r) :: rtodHelper r n -rtod x := +def rtod x := let m := numerator x n := denominator x q := quotient m n r := m % n in (q, map fst (rtodHelper r n)) -rtod' x := +def rtod' x := let m := numerator x n := denominator x q := quotient m n @@ -123,11 +119,11 @@ (s, c) := findCycle (rtodHelper r n) in (q, map fst s, map fst c) -showDecimal c x := - match 2#(%1, take c %2) (rtod x) as (integer, list integer) with +def showDecimal c x := + match (\(x, y) -> (x, take c y)) (rtod x) as (integer, list integer) with | ($q, $sc) -> foldl S.append (S.append (show q) ".") (map show sc) -showDecimal' x := +def showDecimal' x := match rtod' x as (integer, list integer, list integer) with | ($q, $s, $c) -> foldl @@ -138,14 +134,14 @@ -- -- Continued Fraction -- -regularContinuedFraction n xs := n + foldr (\a r -> 1 / (a + r)) 0 xs +def regularContinuedFraction n xs := n + foldr (\a r -> 1 / (a + r)) 0 xs -continuedFraction n xs ys := +def continuedFraction n xs ys := match (xs, ys) as (list integer, list integer) with | ($x :: $xs, $y :: $ys) -> n + y / continuedFraction x xs ys | ([], []) -> n -regularContinuedFractionOfSqrtHelper m a b := +def regularContinuedFractionOfSqrtHelper m a b := let n := floor (f.+ (rtof a) (f.* (rtof b) (sqrt (rtof m)))) x := m - power n 2 in if x = 0 @@ -156,15 +152,15 @@ ((a - n) / y) (neg (b / y)) -regularContinuedFractionOfSqrt m := +def regularContinuedFractionOfSqrt m := let n := floor (sqrt (rtof m)) x := m - power n 2 in if x = 0 then (n, []) else ( n - , map 3#%3 (regularContinuedFractionOfSqrtHelper m (n / x) (1 / x)) ) + , map (\(_, _, z) -> z) (regularContinuedFractionOfSqrtHelper m (n / x) (1 / x)) ) -regularContinuedFractionOfSqrt' m := +def regularContinuedFractionOfSqrt' m := let n := floor (sqrt (rtof m)) x := m - power n 2 in if x = 0 @@ -174,6 +170,6 @@ m (n / x) (1 / x)) - in (n, map 3#%3 s, map 3#%3 c) + in (n, map (\(_, _, x) -> x) s, map (\(_, _, x) -> x) c) -pi := f.pi +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 @@ -4,18 +4,18 @@ -- -- -ordering := +def ordering := algebraicDataMatcher | less | equal | greater -compare m n := +def compare m n := if isCollection m then compareC m n else if m < n then Less else if m = n then Equal else Greater -compareC c1 c2 := +def compareC c1 c2 := match (c1, c2) as (list something, list something) with | ([], []) -> Equal | ([], _) -> Less @@ -23,21 +23,18 @@ | ($x :: $xs, #x :: $ys) -> compareC xs ys | ($x :: _, $y :: _) -> compare x y -min $x $y := if x < y then x else y - -max $x $y := if x > y then x else y - -min/fn f $xs := foldl1 2#(if f %1 %2 = Less then %1 else %2) xs - -max/fn f $xs := foldl1 2#(if f %1 %2 = Greater then %1 else %2) xs +def min $x $y := if x < y then x else y +def max $x $y := if x > y then x else y -minimum $xs := foldl1 min xs +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 -maximum $xs := foldl1 max xs +def minimum $xs := foldl1 min xs +def maximum $xs := foldl1 max xs -splitByOrdering := 2#(splitByOrdering/fn compare %1 %2) +def splitByOrdering := splitByOrdering/fn compare -splitByOrdering/fn f p xs := +def splitByOrdering/fn f p xs := match xs as list something with | [] -> ([], [], []) | $x :: $rs -> @@ -47,9 +44,9 @@ | equal -> (ys1, x :: ys2, ys3) | greater -> (ys1, ys2, x :: ys3) -sort := 1#(sort/fn compare %1) +def sort := sort/fn compare -sort/fn f xs := +def sort/fn f xs := match xs as list something with | [] -> [] | $x :: [] -> [x] @@ -59,25 +56,25 @@ (ys1, ys2, ys3) := splitByOrdering/fn f p xs in sort/fn f ys1 ++ ys2 ++ sort/fn f ys3 -sortStrings xs := +def sortStrings xs := sort/fn 2#(compareC (map ctoi (unpack %1)) (map ctoi (unpack %2))) xs -merge xs ys := +def merge xs ys := match (xs, ys) as (list something, list something) with | ([], _) -> ys | (_, []) -> xs | ($x :: $txs, ?(>= x) :: _) -> x :: merge txs ys | (_, $y :: $tys) -> y :: merge xs tys -merge/fn f xs ys := +def merge/fn f xs ys := match (xs, ys) as (list something, list something) with | ([], _) -> ys | (_, []) -> xs | ($x :: $txs, ?1#(f %1 x = Greater) :: _) -> x :: merge txs ys | (_, $y :: $tys) -> y :: merge xs tys -minimize f xs := +def minimize f xs := foldl1 2#(if compare (f %1) (f %2) = Less then %1 else %2) xs -maximize f xs := +def maximize f xs := foldl1 2#(if compare (f %1) (f %2) = Greater then %1 else %2) xs diff --git a/lib/core/random.egi b/lib/core/random.egi --- a/lib/core/random.egi +++ b/lib/core/random.egi @@ -4,11 +4,11 @@ -- -- -rands s e := pureRand s e :: rands s e +def rands s e := pureRand s e :: rands s e -pureRand s e := io rand s e +def pureRand s e := io (rand s e) -randomize xs := +def randomize xs := let randomize' xs n := if n = 0 then [] @@ -17,9 +17,9 @@ in x :: randomize' (deleteFirst x xs) (n - 1) in randomize' xs (length xs) -R.between s e := randomize [s..e] +def R.between s e := randomize [s..e] -R.multiset a := +def R.multiset a := matcher | [] as () with | [] -> [()] @@ -37,24 +37,24 @@ | $ as (something) with | $tgt -> [tgt] -R.uncons xs := +def R.uncons xs := head (matchAll xs as R.multiset something with | $x :: $rs -> (x, rs)) -R.head xs := +def R.head xs := head (matchAll xs as R.multiset something with | $x :: _ -> x) -R.tail xs := +def R.tail xs := head (matchAll xs as R.multiset something with | _ :: $rs -> rs) -sample := R.head +def sample := R.head -R.set a := +def R.set a := matcher | [] as () with | [] -> [()] @@ -71,6 +71,6 @@ | $ as (something) with | $tgt -> [tgt] -f.rands s e := f.pureRand s e :: f.rands s e +def f.rands s e := f.pureRand s e :: f.rands s e -f.pureRand s e := io f.rand s e +def f.pureRand s e := io (f.rand s e) diff --git a/lib/core/shell.egi b/lib/core/shell.egi --- a/lib/core/shell.egi +++ b/lib/core/shell.egi @@ -1,53 +1,58 @@ -SH.genInput sopts copts := - if io isEof () +def SH.genInput sopts copts := + if io $ isEof () then [] - else let x := io TSV.readLine sopts copts + else let line := io $ readLine () + x := TSV.parseLine sopts copts line in seq x (x :: SH.genInput sopts copts) -TSV.readLine sopts copts := - do let line := readLine () - let fs := S.split "\t" line - in let fnS := \match as (list (list integer), list string) with - | ([], $fs) -> fs - | ( [$m] :: $opts' - , ($hs & ?(\hs -> m - 1 = length hs)) ++ $ts ) -> - fnS - opts' - (hs ++ map (\t -> S.concat ["\"", t, "\""]) ts) - | ( [$m, #m] :: $opts' - , ($hs & ?(\hs -> m - 1 = length hs)) ++ $mf :: $ts ) -> - fnS opts' (hs ++ S.concat ["\"", mf, "\""] :: ts) - | ( [$m, $n] :: $opts' - , ($hs & ?(\hs -> m - 1 = length hs)) ++ - ($ms & ?(\ms -> n - m + 1 = length ms)) ++ $ts ) -> - fnS - opts' - (hs ++ map (\m -> S.concat ["\"", m, "\""]) ms ++ ts) - | ([$m, _] :: $opts', _) -> fnS ([m] :: opts') fs - | (_, _) -> fs - fnC := \match as (list (list integer), list string) with - | ([], $fs) -> fs - | ( [$m] :: $opts' - , ($hs & ?(\hs -> m - 1 = length hs)) ++ [$mf] ) -> - fnC opts' (hs ++ [S.concat ["{", mf, "}"]]) - | ( [$m] :: $opts' - , ($hs & ?(\hs -> m - 1 = length hs)) ++ $mf :: - snoc $tf $ms ) -> - fnC - opts' - (hs ++ S.append "{" mf :: ms ++ [S.append tf "}"]) - | ( [$m, #m] :: $opts' - , ($hs & ?(\hs -> m - 1 = length hs)) ++ $mf :: $ts ) -> - fnC opts' (hs ++ S.concat ["{", mf, "}"] :: ts) - | ( [$m, $n] :: $opts' - , ($hs & ?(\hs -> m - 1 = length hs)) ++ $mf :: - ($ms & ?(\ms -> n - m - 1 = length ms)) ++ $nf :: - $ts ) -> - fnC - opts' - (hs ++ S.append "{" mf :: ms ++ S.append nf "}" :: ts) - | ([$m, _] :: $opts', _) -> fnC ([m] :: opts') fs - | (_, _) -> fs - in return (readTsv (S.intercalate "\t" (fnC copts (fnS sopts fs)))) +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 -TSV.show := showTsv +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 + +def TSV.parseLine sopts copts line := + readTsv (S.intercalate "\t" (fnC copts (fnS sopts (S.split "\t" line)))) + where + fnS sopts xs := + match sopts as list (list integer) with + | [$m] :: $opts' -> + let (hs, ts) := splitAt (m - 1) xs + in fnS opts' (hs ++ map (\t -> S.concat ["\"", t, "\""]) ts) + | [$m, #m] :: $opts' -> + let (hs, ts') := splitAt (m - 1) xs + (mf, ts) := uncons ts' + in fnS opts' (hs ++ S.concat ["\"", mf, "\""] :: ts) + | [$m, $n] :: $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) + | [$m, _] :: $opts' -> fnS ([m] :: opts') xs + | _ -> xs + fnC copts xs := + match copts as list (list integer) with + | [$m] :: $opts' -> + let (hs, ts) := splitAt (m - 1) xs + in fnC opts' (hs ++ [S.concat ["[", S.intercalate ", " ts, "]"]]) + | [$m, #m] :: $opts' -> + let (hs, ts') := splitAt (m - 1) xs + (mf, ts) := uncons ts' + in fnC opts' (hs ++ S.concat ["[", mf, "]"] :: ts) + | [$m, $n] :: $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) + | [$m, _] :: $opts' -> fnC ([m] :: opts') xs + | _ -> xs + +def TSV.show := showTsv diff --git a/lib/core/sort.egi b/lib/core/sort.egi new file mode 100644 --- /dev/null +++ b/lib/core/sort.egi @@ -0,0 +1,44 @@ +-- +-- Sort +-- + +-- input: collection of collection of integers +-- output: a tuple of type (int, collection of integers) +-- where the first element is 1 if the number of swap needed to sort the input +-- is even, and -1 otherwise +-- and the second element is the sorted collection represented as a 1-d tensor +-- (vector) +def sortWithSign xs := + match xs as list something with + -- Optimization for the case where the length is less than 3 + | [] -> (1, xs) + | [$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') + where + colToTensor 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 + then return sgn + else do let x := readIORef ts_i + let y := readIORef ts_j + if compare x y = Greater then swap ts i j else return () + let swapped := return (if compare x y = Greater then -1 else 1) + if j = n then sort' (i + 1) (i + 2) n ts (sgn * swapped) + else sort' i (j + 1) n ts (sgn * swapped) + + swap ts i j := do + let tmpi := readIORef ts_i + let tmpj := readIORef ts_j + writeIORef ts_i tmpj + writeIORef ts_j tmpi diff --git a/lib/core/string.egi b/lib/core/string.egi --- a/lib/core/string.egi +++ b/lib/core/string.egi @@ -4,7 +4,7 @@ -- -- -string := +def string := matcher | regexCg #$regexpr $ $ $ as (string, list string, string) with | $tgt -> regexCg regexpr tgt @@ -38,47 +38,45 @@ -- -- String as collection -- -S.isEmpty xs := xs = "" +def S.isEmpty xs := xs = "" -S.cons x xs := appendString (pack [x]) xs +def S.cons x xs := appendString (pack [x]) xs -S.head xs := +def S.head xs := match xs as string with | $x :: _ -> x -S.tail xs := +def S.tail xs := match xs as string with | _ :: $r -> r -S.last str := +def S.last str := match str as string with - | _ ++ $c :: [] -> c - -S.map f xs := pack (map f (unpack xs)) - -S.length xs := lengthString xs + | _ ++ [$c] -> c -S.split sep ls := splitString sep ls +def S.map f xs := pack (map f (unpack xs)) -S.append xs ys := appendString xs ys +def S.length := lengthString +def S.split := splitString +def S.append := appendString -S.concat xss := foldr (\xs rs -> S.append xs rs) "" xss +def S.concat xss := foldr (\xs rs -> S.append xs rs) "" xss -S.intercalate := compose intersperse S.concat +def S.intercalate sep ss := S.concat (intersperse sep ss) -S.replace before after str := S.intercalate after (S.split before str) +def S.replace before after str := S.intercalate after (S.split before str) -- -- Alphabet -- -C.between c1 c2 := map itoc (between (ctoi c1) (ctoi c2)) +def C.between c1 c2 := map itoc (between (ctoi c1) (ctoi c2)) -C.isBetween c1 c2 c := ctoi c >= ctoi c1 && ctoi c <= ctoi c2 +def C.isBetween c1 c2 c := ctoi c >= ctoi c1 && ctoi c <= ctoi c2 -isAlphabet c := C.isBetween 'a' 'z' c || C.isBetween 'A' 'Z' c +def isAlphabet c := C.isBetween 'a' 'z' c || C.isBetween 'A' 'Z' c -isAlphabetString s := all isAlphabet (unpack s) +def isAlphabetString s := all isAlphabet (unpack s) -upperCase c := if C.isBetween 'a' 'z' c then itoc (ctoi c - 32) else c +def upperCase c := if C.isBetween 'a' 'z' c then itoc (ctoi c - 32) else c -lowerCase c := if C.isBetween 'A' 'Z' c then itoc (ctoi c + 32) else c +def lowerCase c := if C.isBetween 'A' 'Z' c then itoc (ctoi c + 32) else c diff --git a/lib/math/algebra/equations.egi b/lib/math/algebra/equations.egi --- a/lib/math/algebra/equations.egi +++ b/lib/math/algebra/equations.egi @@ -4,49 +4,49 @@ -- -- -solve1 f expr x := inverse expr f x - -solve eqs := solve' eqs [] +def solve eqs := solve' eqs [] + where + solve1 f expr x := inverse expr f x -solve' eqs rets := - match eqs as list (mathExpr, mathExpr, symbolExpr) with - | [] -> rets - | ($f, $expr, $x) :: $rs -> - solve' - rs - (rets ++ [(x, solve1 (substitute rets f) (substitute rets expr) x)]) + solve' eqs rets := + match eqs as list (mathExpr, mathExpr, symbolExpr) with + | [] -> rets + | ($f, $expr, $x) :: $rs -> + solve' + rs + (rets ++ [(x, solve1 (substitute rets f) (substitute rets expr) x)]) -- -- Quadratic Equations -- -quadraticFormula := qF +def quadraticFormula := qF -qF f x := +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 -qF' a b c := +def qF' a b c := ( ((- b) + sqrt (b ^ 2 - 4 * a * c)) / 2 * a , ((- b) - sqrt (b ^ 2 - 4 * a * c)) / 2 * a ) -- -- Cubic Equations -- -cubicFormula := cF +def cubicFormula := cF -cF f x := +def cF f x := match coefficients f x as list mathExpr with | $a_0 :: $a_1 :: $a_2 :: $a_3 :: [] -> cF' a_3 a_2 a_1 a_0 -cF' a b c d := +def cF' a b c d := match (a, b, c, d) as (mathExpr, mathExpr, mathExpr, mathExpr) with | (#1, #0, $p, $q) -> - let (s1, s2) := 2#(rt 3 %1, rt 3 %2) (qF' 1 (27 * q) ((-27) * p ^ 3)) + let (s1, s2) := (\(x, y) -> (rt 3 x, rt 3 y)) (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 | (#1, _, _, _) -> - 3#(%1 - b / 3, %2 - b / 3, %3 - b / 3) - (withSymbols [x, y] - cF (substitute [(x, y - b / 3)] (x ^ 3 + b * x ^ 2 + c * x + d)) y) + let (s1, s2, s3) := withSymbols [x, y] + cF (substitute [(x, y - b / 3)] (x ^ 3 + b * x ^ 2 + c * x + d)) y + in (s1 - b / 3, s2 - b / 3, s3 - b / 3) | (_, _, _, _) -> cF' 1 (b / a) (c / a) (d / a) diff --git a/lib/math/algebra/inverse.egi b/lib/math/algebra/inverse.egi --- a/lib/math/algebra/inverse.egi +++ b/lib/math/algebra/inverse.egi @@ -2,7 +2,7 @@ -- Inverse -- -inverse t f x := +def inverse t f x := match f as mathExpr with | ?isSimpleTerm -> match f as symbolExpr with 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 @@ -2,15 +2,15 @@ -- Matrices -- -M.* %s %t := withSymbols [i, j, k] s~i~j . t_j -M.*' %s %t := withSymbols [i, j, k] s~i~j .' t_j +def M.* %s %t := withSymbols [i, j, k] s~i~j . t_j +def M.*' %s %t := withSymbols [i, j, k] s~i~j .' t_j -M.power %t n := foldl M.* t (take (n - 1) (repeat1 t)) +def M.power %t n := foldl M.* t (take (n - 1) (repeat1 t)) --M.power %m n := repeatedSquaring M.* m n -M.comm %m1 %m2 := withSymbols [i, j, k] m1~i~j . m2_j_k - m2~i~j . m1_j_k +def M.comm %m1 %m2 := withSymbols [i, j, k] m1~i~j . m2_j_k - m2~i~j . m1_j_k -M.inverse %m := +def M.inverse %m := let d := M.det m in generateTensor 2#(match m as matrix with @@ -20,9 +20,9 @@ else - (M.det (M.join A B C D) / d)) (tensorShape m) -trace %t := withSymbols [i] sum (contract t~i_i) +def trace %t := withSymbols [i] sum (contract t~i_i) -matrix := +def matrix := matcher | quadCons $ $ $ $ as (mathExpr, matrix, matrix, matrix) with | $tgt -> @@ -45,7 +45,7 @@ | $ as (something) with | $tgt -> [tgt] -M.join %A %B %C %D := +def M.join %A %B %C %D := let ashape := tensorShape A a1 := nth 1 ashape a2 := nth 2 ashape @@ -73,16 +73,16 @@ -- -- Determinant -- -evenAndOddPermutations n := +def evenAndOddPermutations n := let (es, os) := evenAndOddPermutations' n in (map 1#(\i -> nth i %1) es, map 1#(\i -> nth i %1) os) -evenAndOddPermutations0 n := +def evenAndOddPermutations0 n := let (es, os) := evenAndOddPermutations' n in ( map 1#(\i -> nth (i + 1) (map 1#(%1 - 1) %1)) es , map 1#(\i -> nth (i + 1) (map 1#(%1 - 1) %1)) os ) -evenAndOddPermutations' n := +def evenAndOddPermutations' n := match n as integer with | #1 -> ([[1]], []) | #2 -> ([[1, 2]], [[2, 1]]) @@ -92,47 +92,42 @@ os' := map (++ [n]) os in ( es' ++ concat (map - (\i -> map 1#(permutate i n %1) os') + (\i -> map (permutate i n) os') (between 1 (n - 1))) , os' ++ concat (map - (\i -> map 1#(permutate i n %1) es') + (\i -> map (permutate i n) es') (between 1 (n - 1))) ) -permutate x y xs := +def permutate x y xs := match xs as list eq with | $hs ++ #x :: $ms ++ #y :: $ts -> hs ++ y :: ms ++ x :: ts | $hs ++ #y :: $ms ++ #x :: $ts -> hs ++ x :: ms ++ y :: ts -M.determinant %m := +def M.determinant %m := match tensorShape m as list integer with - | #0 :: #0 :: [] -> 1 - | $n :: #n :: [] -> + | [#0, #0] -> 1 + | [$n, #n] -> let (es, os) := evenAndOddPermutations' n - in sum - (map - (\e -> product (map2 (\i j -> m_i_j) (between 1 n) e)) - es) - sum - (map - (\o -> product (map2 (\i j -> m_i_j) (between 1 n) o)) - os) + in sum (map (\e -> product (map2 (\i j -> m_i_j) (between 1 n) e)) es) - + sum (map (\o -> product (map2 (\i j -> m_i_j) (between 1 n) o)) os) | _ -> undefined -M.det := M.determinant +def M.det := M.determinant -- -- Eigenvalues and eigenvectors -- -M.eigenvalues %m := +def M.eigenvalues %m := match tensorShape m as list integer with - | #2 :: #2 :: [] -> + | [#2, #2] -> let (e1, e2) := qF (M.det (T.- m (scalarToTensor x [2, 2]))) x in [e1, e2] | _ -> undefined -M.eigenvectors %m := +def M.eigenvectors %m := match tensorShape m as list integer with - | #2 :: #2 :: [] -> + | [#2, #2] -> let (e1, e2) := qF (M.det (T.- m (scalarToTensor x [2, 2]))) x in [ (e1, clearIndex (T.- m (scalarToTensor e1 [2, 2]))_i_1) , (e2, clearIndex (T.- m (scalarToTensor e2 [2, 2]))_i_1) ] @@ -141,9 +136,9 @@ -- -- LU decomposition -- -M.LU %x := +def M.LU %x := match tensorShape x as list integer with - | #2 :: #2 :: [] -> + | [#2, #2] -> let L := generateTensor 2#(match compare %1 %2 as ordering with | less -> 0 @@ -162,7 +157,7 @@ , (m_2_1, x_2_1, b_2_1) , (m_2_2, x_2_2, c_2_2) ] in (substitute ret L, substitute ret U) - | #3 :: #3 :: [] -> + | [#3, #3] -> let L := generateTensor 2#(match compare %1 %2 as ordering with | less -> 0 @@ -191,7 +186,7 @@ -- -- Utility -- -generateMatrixFromQuadraticExpr f xs := +def generateMatrixFromQuadraticExpr f xs := generateTensor 2#(coefficient2 f (nth %1 xs) (nth %2 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 @@ -7,12 +7,12 @@ -- -- Root -- -rt n x := +def rt n x := if isInteger n then match x as mathExpr with | #0 -> 0 | ?isMonomial -> rtMonomial n x - | (poly $xs) / (poly $ys) -> + | poly $xs / poly $ys -> let xd := reduce gcd xs yd := reduce gcd ys d := rtMonomial n (xd / yd) @@ -20,63 +20,59 @@ | _ -> rt'' n x else rt'' n x -rtMonomial n x := +def rtMonomial n x := rtTerm n (numerator x * denominator x ^ (n - 1)) / denominator x -rtTerm n x := +def rtTerm n x := match x as termExpr with | term $a _ -> - if a < 0 then rtm1 n *' rtPositiveTerm n (- x) else rtPositiveTerm n x + let rtm1 n := match n as integer with + | #1 -> -1 + | #2 -> i + | ?isOdd -> -1 + | _ -> undefined + in if a < 0 then rtm1 n *' rtPositiveTerm n (- x) else rtPositiveTerm n x -rtPositiveTerm n x := +def rtPositiveTerm n x := match (n, x) as (mathExpr, mathExpr) with | (#3, $a * #i * $r) -> (- i) * rt 3 (a *' r) | (_, $a * #sqrt $b * $r) -> rt (n * 2) (a ^' 2 *' b) *' rt n r | (_, $a * #rt $n' $b * $r) -> rt (n * n') (a ^' n' *' b) *' rt n r | (_, _) -> rtPositiveTerm1 n x - -rtPositiveTerm1 n x := - let f xs := - match xs as assocMultiset mathExpr with - | [] -> (1, 1) - | ncons $p $k $rs -> - let (a, b) := f rs - in (p ^' quotient k n *' a, p ^' (k % n) *' b) - g n x := - let d := match x as termExpr with - | term $m $xs -> - gcd n (reduce gcd (map 2#%2 (toAssoc (pF m) ++ xs))) - in rt'' (n / d) (rt d x) - in match x as termExpr with - | term $m $xs -> - match f (toAssoc (pF (abs m)) ++ xs) as (integer, integer) with - | ($a, #1) -> a - | ($a, $b) -> a *' g n b + where + rtPositiveTerm1 n x := + let f xs := + match xs as assocMultiset mathExpr with + | [] -> (1, 1) + | ncons $p $k $rs -> + let (a, b) := f rs + in (p ^' quotient k n *' a, p ^' (k % n) *' b) + g n x := + let d := match x as termExpr with + | term $m $xs -> + gcd n (reduce gcd (map snd (toAssoc (pF m) ++ xs))) + in rt'' (n / d) (rt d x) + in match x as termExpr with + | term $m $xs -> + match f (toAssoc (pF (abs m)) ++ xs) as (integer, integer) with + | ($a, #1) -> a + | ($a, $b) -> a *' g n b -rt'' n x := +def rt'' n x := match (n, x) as (integer, integer) with | (#2, _) -> `sqrt x | (_, _) -> `rt n x -rtm1 n := - match n as integer with - | #1 -> -1 - | #2 -> i - | ?isOdd -> -1 - | _ -> undefined - -sqrt x := +def sqrt x := if isScalar x then let m := numerator x n := denominator x in rt 2 (m * n) / n else b.sqrt x -rtOfUnity := rtu - -rtu n := rtu' n +def rtOfUnity := rtu -rtu' n := +def rtu n := if isInteger n then match n as integer with | #1 -> 1 diff --git a/lib/math/algebra/tensor.egi b/lib/math/algebra/tensor.egi --- a/lib/math/algebra/tensor.egi +++ b/lib/math/algebra/tensor.egi @@ -4,14 +4,17 @@ -- -- -tensorOrder %A := length (tensorShape A) +infixl expression 7 . +infixl expression 7 .' -unitTensor ns := generateTensor kroneckerDelta ns +def tensorOrder %A := length (tensorShape A) -scalarToTensor x ns := x * unitTensor ns +def unitTensor ns := generateTensor kroneckerDelta ns -zeroTensor ns := generateTensor (cambda xs -> 0) ns +def scalarToTensor x ns := x * unitTensor ns -(.') %t1 %t2 := sum' (contract (t1 *' t2)) +def zeroTensor ns := generateTensor (\xs -> 0) ns -(.) %t1 %t2 := sum (contract (t1 * t2)) +def (.') %t1 %t2 := sum' (contract (t1 *' t2)) + +def (.) %t1 %t2 := sum (contract (t1 * t2)) diff --git a/lib/math/algebra/vector.egi b/lib/math/algebra/vector.egi --- a/lib/math/algebra/vector.egi +++ b/lib/math/algebra/vector.egi @@ -2,15 +2,15 @@ -- Vectors -- -dotProduct %v1 %v2 := withSymbols [i] v1~i . v2_i +def dotProduct %v1 %v2 := withSymbols [i] v1~i . v2_i -V.* := dotProduct +def V.* := dotProduct -crossProduct/fn fn %a %b := +def crossProduct/fn fn %a %b := [|fn a_2 b_3 - fn a_3 b_2, fn a_3 b_1 - fn a_1 b_3, fn a_1 b_2 - fn a_2 b_1|] -crossProduct %a %b := crossProduct/fn (*) a b +def crossProduct %a %b := crossProduct/fn (*) a b -div %A %xs := trace (∇ A xs) +def div %A %xs := trace (∇ A xs) -rot %A %xs := crossProduct/fn ∂/∂ A xs +def rot %A %xs := crossProduct/fn ∂/∂ A xs diff --git a/lib/math/analysis/derivative.egi b/lib/math/analysis/derivative.egi --- a/lib/math/analysis/derivative.egi +++ b/lib/math/analysis/derivative.egi @@ -4,7 +4,7 @@ -- -- -∂/∂ $f *x := +def ∂/∂ $f *$x := match f as mathExpr with -- symbol | #x -> 1 @@ -21,7 +21,7 @@ | #`sin $g -> cos g * ∂/∂ g x | #`arccos $g -> 1 / sqrt (1 - g ^ 2) * ∂/∂ g x | apply $g $args -> - sum (map 2#((capply `(userRefs g [%1]) args) * ∂/∂ %2 x) (zip nats args)) + sum (map2 2#((capply `(userRefs g [%1]) args) * ∂/∂ %2 x) nats args) -- quote | quote $g -> let g' := ∂/∂ g x @@ -43,21 +43,21 @@ p2' := ∂/∂ p2 x in (p1' * p2 - p2' * p1) / p2 ^ 2 -d/d := ∂/∂ +def d/d := ∂/∂ -pd/pd := ∂/∂ +def pd/pd := ∂/∂ -∇ := ∂/∂ +def ∇ := ∂/∂ -nabla := ∇ +def nabla := ∇ -grad := ∇ +def grad := ∇ -taylorExpansion $f $x $a := multivariateTaylorExpansion f [|x|] [|a|] +def taylorExpansion $f $x $a := multivariateTaylorExpansion f [|x|] [|a|] -maclaurinExpansion := 2#(taylorExpansion %1 %2 0) +def maclaurinExpansion := 2#(taylorExpansion %1 %2 0) -multivariateTaylorExpansion $f %xs %ys := +def multivariateTaylorExpansion $f %xs %ys := withSymbols [h] let hs := generateTensor 1#h_%1 (tensorShape xs) in map2 @@ -69,9 +69,5 @@ 1#(V.substitute hs (withSymbols [i] xs_i - ys_i) %1)) (iterate (compose 1#(∇ %1 xs) 1#(V.* hs %1)) f)) -multivariateMaclaurinExpansion $f %xs := +def multivariateMaclaurinExpansion $f %xs := multivariateTaylorExpansion f xs (tensorMap 1#0 xs) - -addUserScript $f $i := - let (g, is) := deconsUserScripts f - in appendUserScripts g (sort (is ++ [i])) 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 @@ -4,7 +4,7 @@ -- -- -Sd x f := +def Sd x f := match f as mathExpr with -- symbols | #x -> 1 / 2 * x ^ 2 @@ -29,13 +29,13 @@ -- polynomial | poly $ts -> sum (map 1#(Sd x %1) ts) -- quotient - | (plus $ts) / $p2 -> sum (map 1#(Sd x (%1 / p2)) ts) + | 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 -multSd x f g := +def multSd x f g := let F := Sd x f in F * g - Sd x (F * d/d g x) -dSd x a b f := +def dSd x a b f := let F := Sd x f in substitute [(x, b)] F - substitute [(x, a)] F diff --git a/lib/math/common/arithmetic.egi b/lib/math/common/arithmetic.egi --- a/lib/math/common/arithmetic.egi +++ b/lib/math/common/arithmetic.egi @@ -4,59 +4,63 @@ -- -- -toMathExpr arg := mathNormalize (toMathExpr' arg) - -(+') $x $y := b.+ x y +def toMathExpr arg := mathNormalize (toMathExpr' arg) -(-') $x $y := b.- x y +infixl expression 6 + +infixl expression 6 - +infixl expression 7 * +infixl expression 7 / +infixl expression 8 ^ -(*') $x $y := b.* x y +infixl expression 6 +' +infixl expression 6 -' +infixl expression 7 *' +infixl expression 7 /' +infixl expression 8 ^' -(/') $x $y := b./ x y +def (+') := b.+ +def (-') := b.- +def (*') := b.* +def (/') := b./ -(+) $x $y := +def (+) $x $y := match (isFloat x, isFloat y) as eq with | #(True, True) -> f.+ x y | #(True, False) -> f.+ x (itof y) | #(False, True) -> f.+ (itof x) y | _ -> mathNormalize (x +' y) -(-) $x $y := +def (-) $x $y := match (isFloat x, isFloat y) as eq with | #(True, True) -> f.- x y | #(True, False) -> f.- x (itof y) | #(False, True) -> f.- (itof x) y | _ -> mathNormalize (x -' y) -(*) $x $y := +def (*) $x $y := match (isFloat x, isFloat y) as eq with | #(True, True) -> f.* x y | #(True, False) -> f.* x (itof y) | #(False, True) -> f.* (itof x) y | _ -> mathNormalize (x *' y) -(/) $x $y := +def (/) $x $y := match (isFloat x, isFloat y) as eq with | #(True, True) -> f./ x y | #(True, False) -> f./ x (itof y) | #(False, True) -> f./ (itof x) y | _ -> x /' y -reduceFraction := id - -sum xs := foldl (+) 0 xs - -sum' xs := foldl (+') 0 xs - -product xs := foldl (*) 1 xs - -product' xs := foldl (*') 1 xs +def sum xs := foldl (+) 0 xs +def sum' xs := foldl (+') 0 xs -power $x $n := mathNormalize (power' x n) +def product xs := foldl (*) 1 xs +def product' xs := foldl (*') 1 xs -power' $x $n := foldl (*') 1 (take n (repeat1 x)) +def power $x $n := mathNormalize (power' x n) +def power' $x $n := foldl (*') 1 (take n (repeat1 x)) -(^) $x $n := +def (^) $x $n := if x = e then exp n else if isRational n @@ -65,7 +69,7 @@ else 1 / x ^ neg n else `(^) x n -(^') $x $n := +def (^') $x $n := if x = e then exp n else if isRational n @@ -74,21 +78,21 @@ else 1 /' x ^' neg n else `(^) x n -gcd $x $y := +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' $x $y := +def gcd' $x $y := match (x, y) as (integer, integer) with | (_, #0) -> x | (#0, _) -> y | (_, ?(>= x)) -> gcd' (modulo y x) x | (_, _) -> gcd' y x -P./ fx $gx $x := +def P./ fx $gx $x := let xs := reverse (coefficients fx x) ys := reverse (coefficients gx x) (zs, rs) := L./ xs ys diff --git a/lib/math/common/constants.egi b/lib/math/common/constants.egi --- a/lib/math/common/constants.egi +++ b/lib/math/common/constants.egi @@ -2,5 +2,5 @@ -- Mathematical constants -- -MinkowskiMetric := +def MinkowskiMetric := [|[|-1, 0, 0, 0|], [|0, 1, 0, 0|], [|0, 0, 1, 0|], [|0, 0, 0, 1|]|] 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 @@ -2,11 +2,11 @@ -- Mathematical Functions -- -abs $x := if isRational x then b.abs x else x +def abs $x := if isRational x then b.abs x else x -neg $x := if isRational x then b.neg x else - x +def neg $x := if isRational x then b.neg x else - x -exp $x := +def exp $x := if isFloat x then b.exp x else if isTerm x @@ -17,7 +17,7 @@ | _ -> `exp x else `exp x -log $x := +def log $x := if isFloat x then b.log x else match x as mathExpr with @@ -25,7 +25,7 @@ | #e -> 1 | _ -> `log x -cos $x := +def cos $x := if isFloat x then b.cos x else match x as mathExpr with @@ -34,7 +34,7 @@ | (mult _ #π) / #2 -> 0 | _ -> `cos x -sin $x := +def sin $x := if isFloat x then b.sin x else match x as mathExpr with @@ -43,56 +43,56 @@ | (mult $n #π) / #2 -> (-1) ^ ((abs n - 1) / 2) | _ -> `sin x -tan $x := +def tan $x := if isFloat x then b.tan x else match x as mathExpr with | #0 -> 0 | _ -> `tan x -acos := b.acos -asin := b.asin -atan := b.atan +def acos := b.acos +def asin := b.asin +def atan := b.atan -cosh $x := +def cosh $x := if isFloat x then b.cosh x else match x as mathExpr with | #0 -> 1 | _ -> `cosh x -sinh $x := +def sinh $x := if isFloat x then b.sinh x else match x as mathExpr with | #0 -> 0 | _ -> `sinh x -tanh $x := +def tanh $x := if isFloat x then b.tanh x else match x as mathExpr with | #0 -> 0 | _ -> `tanh x -acosh := b.acosh -asinh := b.asinh -atanh := b.atanh +def acosh := b.acosh +def asinh := b.asinh +def atanh := b.atanh -sinc $x := +def sinc $x := if isFloat x then if x = 0.0 then 1.0 else b.sin x / x else match x as mathExpr with | #0 -> 1 | _ -> sin x / x -sigmoid $z := 1 / (1 + exp (- z)) +def sigmoid $z := 1 / (1 + exp (- z)) -kroneckerDelta := cambda js -> if all (= head js) (tail js) then 1 else 0 +def kroneckerDelta := cambda js -> if all (= head js) (tail js) then 1 else 0 -eulerTotientFunction $n := n * product (map (\p -> 1 - 1 / p) (unique (pF n))) +def eulerTotientFunction $n := n * product (map (\p -> 1 - 1 / p) (unique (pF n))) -ε := +def ε := memoizedLambda n -> let (es, os) := evenAndOddPermutations' n in generateTensor @@ -100,7 +100,7 @@ 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 diff --git a/lib/math/expression.egi b/lib/math/expression.egi --- a/lib/math/expression.egi +++ b/lib/math/expression.egi @@ -4,33 +4,47 @@ -- -- -mathExpr := +infixr pattern 6 + +infixr pattern 7 * +infix pattern 7 / +infix pattern 8 ^ + +def mathExpr := matcher | #$val as () with | $tgt -> if val = tgt then [()] else [] | $ as (mathExpr') with | $tgt -> [fromMathExpr tgt] -mathExpr' := +def mathExpr' := matcher - | div $ $ as (mathExpr, mathExpr) with + | $ / $ as (mathExpr, mathExpr) with | Div $p1 $p2 -> [(toMathExpr' p1, toMathExpr' p2)] | _ -> [] | poly $ as (multiset mathExpr) with | Div (Plus $ts) (Plus [Term 1 []]) -> [map toMathExpr' ts] | _ -> [] - | plus $ as (plusExpr) with + | plus $ as (multiset mathExpr) with | Div (Plus $ts) (Plus [Term 1 []]) -> - [toMathExpr' (Div (Plus ts) (Plus [Term 1 []]))] + map (\t -> toMathExpr' (Div (Plus [t]) (Plus [Term 1 []]))) ts | _ -> [] + | $ + $ as (mathExpr, mathExpr) with + | Div (Plus $ts) (Plus [Term 1 []]) -> + matchAll (map toMathExpr' ts) as multiset something with + | $t :: $tss -> (t, sum' tss) + | _ -> [] | term $ $ as (integer, assocMultiset mathExpr) with | Div (Plus [Term $n $xs]) (Plus [Term 1 []]) -> - [(n, map 2#(toMathExpr' %1, %2) xs)] + [(n, map (\(x, n) -> (toMathExpr' x, n)) xs)] | _ -> [] | mult $ $ as (integer, multExpr) with | Div (Plus [Term $n $xs]) (Plus [Term 1 []]) -> - [(n, product' (map 2#(toMathExpr' %1 ^' %2) xs))] + [(n, product' (map (\(x, n) -> toMathExpr' x ^' n) xs))] | _ -> [] + | $ * $ as (integer, multExpr) with + | Div (Plus [Term $n $xs]) (Plus [Term 1 []]) -> + [(n, product' (map (\(x, n) -> toMathExpr' x ^' n) xs))] + | _ -> [] | symbol $ $ as (eq, list indexExpr) with | Div (Plus [Term 1 [(Symbol $v $js, 1)]]) (Plus [Term 1 []]) -> [(v, js)] @@ -44,95 +58,79 @@ [toMathExpr' mexpr] | _ -> [] | func $ $ $ $ as - (mathExpr, list mathExpr, list mathExpr, list indexExpr ) with + (mathExpr, list mathExpr, list mathExpr, list indexExpr) with | Div (Plus [Term 1 [(Function $name $argnames $args $js, 1)]]) (Plus [Term 1 []]) -> [(name, argnames, args, js)] | _ -> [] - | $ as (something) with + | $ as something with | $tgt -> [toMathExpr' tgt] -indexExpr := +def indexExpr := algebraicDataMatcher | sub mathExpr | sup mathExpr | user mathExpr -polyExpr := mathExpr - -termExpr := mathExpr +def polyExpr := mathExpr -symbolExpr := mathExpr +def termExpr := mathExpr -plusExpr := - matcher - | [] as () with - | $tgt -> if tgt = 0 then [()] else [] - | $ :: $ as (mathExpr, plusExpr) with - | $tgt -> - matchAll tgt as mathExpr with - | poly ($t :: $ts) -> (t, sum' ts) - | $ as (mathExpr) with - | $tgt -> [tgt] +def symbolExpr := mathExpr -multExpr := +def multExpr := matcher | [] as () with | $tgt -> match tgt as mathExpr with | #0 -> [()] | _ -> [] - | $ :: $ as (mathExpr, multExpr) with + | $ ^ #$k * $ as (mathExpr, multExpr) with | $tgt -> - match tgt as mathExpr with - | term _ $xs -> - matchAll xs as assocMultiset mathExpr with - | $x :: $rs -> (x, product' (map (^') rs)) - | _ -> [] - | ncons $ #$k $ as (mathExpr, multExpr) with + matchAll tgt as mathExpr with + | term _ (ncons $x #k $xs) -> (x, product' (map (uncurry (^')) xs)) + | $ ^ $ * $ as (mathExpr, integer, multExpr) with | $tgt -> - match tgt as mathExpr with - | term _ $xs -> - matchAll xs as list (mathExpr, integer) with - | $hs ++ ($x, ?(>= k) & $n) :: $ts -> - (x, product' (map (^') (hs ++ (x, n - k) :: ts))) - | _ -> [] - | ncons $ $ $ as (mathExpr, integer, multExpr) with + matchAll tgt as mathExpr with + | term _ (ncons $x $n $xs) -> (x, n, product' (map (uncurry (^')) xs)) + | $ ^ $ as (mathExpr, integer) with | $tgt -> match tgt as mathExpr with - | term _ $xs -> - matchAll xs as list (mathExpr, integer) with - | $hs ++ ($x, $n) :: $ts -> (x, n, product' (map (^') (hs ++ ts))) + | term _ (ncons $x $n []) -> [(x, n)] | _ -> [] - | $ as (mathExpr) with + | $ * $ as (mathExpr, multExpr) with + | $tgt -> + matchAll tgt as mathExpr with + | term _ ($x :: $rs) -> (x, product' (map (uncurry (^')) rs)) + | $ as mathExpr with | $tgt -> [tgt] -isSymbol %mexpr := +def isSymbol %mexpr := match mexpr as mathExpr with | symbol _ _ -> True | _ -> False -isApply %mexpr := +def isApply %mexpr := match mexpr as mathExpr with | apply _ _ -> True | _ -> False -isSimpleTerm := 1#(isSymbol %1 || isApply %1) +def isSimpleTerm mexpr := isSymbol mexpr || isApply mexpr -isTerm %mexpr := +def isTerm %mexpr := match mexpr as mathExpr with | term _ _ -> True | #0 -> True | _ -> False -isPolynomial %mexpr := +def isPolynomial %mexpr := match mexpr as mathExpr with | poly _ -> True | #0 -> True | _ -> False -isMonomial %mexpr := +def isMonomial %mexpr := match mexpr as mathExpr with | poly [term _ _] / poly [term _ _] -> True | #0 -> True @@ -141,168 +139,94 @@ -- -- Accessor -- -symbolIndices $mexpr := - match mexpr as mathExpr with - | symbol _ $js -> js - | _ -> undefined - -fromMonomial $mexpr := +def fromMonomial $mexpr := match mexpr as mathExpr with - | (term $a $xs) / (term $b $ys) -> - (a / b, foldl (*') 1 (map (^') xs) / foldl (*') 1 (map (^') ys)) + | term $a $xs / term $b $ys -> + (a / b, foldl (*') 1 (map (uncurry (^')) xs) / foldl (*') 1 (map (uncurry (^')) ys)) -- -- Map -- -mapPolys $fn $mexpr := +def mapPolys $fn $mexpr := match mexpr as mathExpr with | $p1 / $p2 -> fn p1 /' fn p2 -fromPoly $mexpr := +def fromPoly $mexpr := match mexpr as mathExpr with | poly $ts1 / $q -> map (\t1 -> t1 /' q) ts1 -mapPoly $fn $mexpr := +def mapPoly $fn $mexpr := match mexpr as mathExpr with | poly $ts1 / $q -> foldl (+') 0 (map (\t1 -> fn (t1 /' q)) ts1) -mapTerms $fn $mexpr := +def mapTerms $fn $mexpr := match mexpr as mathExpr with | poly $ts1 / poly $ts2 -> foldl (+') 0 (map fn ts1) /' foldl (+') 0 (map fn ts2) -mapSymbols $fn $mexpr := +def mapSymbols $fn $mexpr := mapTerms - (\term -> - match term as termExpr with - | term $a $xs -> - a *' foldl - (*') - 1 - (map - 2#(match %1 as symbolExpr with - | symbol _ _ -> fn %1 ^' %2 - | apply $g $args -> - let args' := map 1#(mapSymbols fn %1) args - in if args = args' - then %1 ^' %2 - else fn (capply g args') ^' %2) - xs)) + (\match as termExpr with + | term $a $xs -> + a *' foldl + (*') + 1 + (map + (\(x, n) -> match x as symbolExpr with + | symbol _ _ -> fn x ^' n + | apply $g $args -> + let args' := map (mapSymbols fn) args + in if args = args' + then x ^' n + else fn (capply g args') ^' n) + xs)) mexpr -containSymbol $x $mexpr := - any - id - (match mexpr as mathExpr with - | poly $ts1 / poly $ts2 -> - map - (\term -> - match term as termExpr with - | term _ $xs -> - any - id - (map - 2#(match %1 as symbolExpr with - | #x -> True - | apply _ $args -> - any id (map 1#(containSymbol x %1) args) - | _ -> False) - xs)) - (ts1 ++ ts2)) - -containFunction $f $mexpr := - any - id - (match mexpr as mathExpr with - | poly $ts1 / poly $ts2 -> - map - (\term -> - match term as termExpr with - | term _ $xs -> - any - id - (map - 2#(match %1 as symbolExpr with - | apply $g $args -> - if f = g - then True - else any id (map 1#(containFunction f %1) args) - | _ -> False) - xs)) - (ts1 ++ ts2)) - -containFunctionWithOrder $f $n $mexpr := - any - id - (match mexpr as mathExpr with - | poly $ts1 / poly $ts2 -> - map - (\term -> - match term as termExpr with - | term _ $xs -> - any - id - (map - 2#(match %1 as symbolExpr with - | apply $g $args -> - if f = g && %2 >= n - then True - else any - id - (map - 1#(containFunctionWithOrder f n %1) - args) - | _ -> False) - xs)) - (ts1 ++ ts2)) +def scanAllTerms $mexpr $f := + match mexpr as mathExpr with + | poly $ts1 / poly $ts2 -> any f (ts1 ++ ts2) -containFunctionWithIndex $mexpr := - any - id - (match mexpr as mathExpr with - | poly $ts1 / poly $ts2 -> - map - (\term -> - match term as termExpr with - | term _ $xs -> - any - id - (map - 2#(match %1 as symbolExpr with - | apply (?isScalar & $f) $args -> - match f as mathExpr with - | symbol _ ![] -> True - | _ -> - any id (map 1#(containFunctionWithIndex %1) args) - | apply _ $args -> - any id (map 1#(containFunctionWithIndex %1) args) - | _ -> False) - xs)) - (ts1 ++ ts2)) +def containSymbol $x $mexpr := + scanAllTerms mexpr + (\match as termExpr with + | term _ $xs -> + any + (\(y, _) -> match y as symbolExpr with + | #x -> True + | apply _ $args -> any (containSymbol x) args + | _ -> False) + xs) -findSymbolsFromPoly $poly := - matchAll poly as mathExpr with - | poly (term _ ((symbol _ _ & $s) :: _) :: _) -> s +def containFunction $f $mexpr := + scanAllTerms mexpr + (\match as termExpr with + | term _ $xs -> + any + (\(y, _) -> match y as symbolExpr with + | apply #f _ -> True + | apply $g $args -> any (containFunction f) args + | _ -> False) + xs) -- -- Substitute -- -substitute %ls $mexpr := +def substitute %ls $mexpr := match ls as list (symbolExpr, mathExpr) with - | [] -> mexpr + | [] -> mathNormalize mexpr | ($x, $a) :: $rs -> substitute rs (substitute' x a mexpr) -substitute' $x %a $mexpr := mapSymbols 1#(rewriteSymbol x a %1) mexpr +def substitute' $x %a $mexpr := mapSymbols (rewriteSymbol x a) mexpr -rewriteSymbol $x $a $sexpr := +def rewriteSymbol $x $a $sexpr := match sexpr as symbolExpr with | #x -> a | _ -> sexpr -V.substitute %xs %ys $mexpr := +def V.substitute %xs %ys $mexpr := substitute (zip (tensorToList xs) (tensorToList ys)) mexpr -expandAll $mexpr := +def expandAll $mexpr := match mexpr as mathExpr with | ?isSymbol -> mexpr -- function application @@ -310,16 +234,13 @@ -- quote | quote $g -> g -- term (multiplication) - | term $a $ps -> a * product (map 2#(expandAll %1 ^ expandAll %2) ps) + | term $a $ps -> a * product (map (\(x, n) -> expandAll x ^ expandAll n) ps) -- polynomial | poly $ts -> sum (map expandAll ts) -- quotient - | $p1 / $p2 -> - let p1' := expandAll p1 - p2' := expandAll p2 - in p1' / p2' + | $p1 / $p2 -> expandAll p1 / expandAll p2 -expandAll' $mexpr := +def expandAll' $mexpr := match mexpr as mathExpr with | ?isSymbol -> mexpr -- function application @@ -327,40 +248,37 @@ -- quote | quote $g -> g -- term (multiplication) - | term $a $ps -> a *' product' (map 2#(expandAll' %1 ^' expandAll' %2) ps) + | term $a $ps -> a *' product' (map (\(x, n) -> expandAll' x ^' expandAll' n) ps) -- polynomial | poly $ts -> sum' (map expandAll' ts) -- quotient - | $p1 / $p2 -> - let p1' := expandAll' p1 - p2' := expandAll' p2 - in p1' /' p2' + | $p1 / $p2 -> expandAll' p1 / expandAll' p2 -- -- Coefficient -- -coefficients $f $x := +def coefficients $f $x := let m := maximum (0 :: (matchAll f as mathExpr with | poly (term $a (ncons #x $k $ts) :: _) / _ -> k)) - in map 1#(coefficient f x %1) (between 0 m) + in map (coefficient f x) (between 0 m) -coefficient $f $x $m := +def coefficient $f $x $m := if m = 0 then sum (matchAll f as mathExpr with | poly (term $a (!(#x :: _) & $ts) :: _) / _ -> - foldl (*') a (map (^') ts)) / denominator f + foldl (*') a (map (uncurry (^')) ts)) / denominator f else coefficient' f x m -coefficient' $f $x $m := +def coefficient' $f $x $m := sum (matchAll f as mathExpr with - | poly (term $a (ncons #x $k $ts) :: _) / _ -> - if m = k then foldl (*') a (map (^') ts) else 0) / denominator f + | poly (term $a (ncons #x #m (!(#x :: _) & $ts)) :: _) / _ -> + foldl (*') a (map (uncurry (^')) ts)) / denominator f -coefficient2 $f $x $y := +def coefficient2 $f $x $y := sum (matchAll f as mathExpr with | poly (term $a (#x :: #y :: $ts) :: _) / _ -> - foldl (*') a (map (^') ts)) / denominator f + foldl (*') a (map (uncurry (^')) ts)) / denominator f 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 @@ -1,6 +1,6 @@ -coordinates := [x, y, z] +def coordinates := [x, y, z] -metric := +def metric := generateTensor (\match as (integer, integer) with | ($n, #n) -> 1 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 @@ -1,6 +1,6 @@ -coordinates := [x, y, z, w] +def coordinates := [x, y, z, w] -metric := +def metric := generateTensor (\match as (integer, integer) with | ($n, #n) -> 1 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 @@ -1,4 +1,4 @@ -dfNormalize %X := +def dfNormalize %X := let p := dfOrder X (es, os) := evenAndOddPermutations p in withSymbols [i] @@ -6,15 +6,15 @@ - sum (map (\σ -> subrefs X (map 1#i_(σ %1) (between 1 p))) os)) / fact p -antisymmetrize := dfNormalize +def antisymmetrize := dfNormalize -wedge %X %Y := X !. Y +def wedge %X %Y := X !. Y -Lie.wedge %X %Y := X !. Y - Y !. X +def Lie.wedge %X %Y := X !. Y - Y !. X -ι %X %Y := withSymbols [i] dfOrder Y * (X...~i . dfNormalize Y..._i) +def ι %X %Y := withSymbols [i] dfOrder Y * (X...~i . dfNormalize Y..._i) -Lie %X %Y := +def Lie %X %Y := match dfOrder Y as integer with | #0 -> ι X (d Y) | #N -> d (ι X Y) 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 @@ -1,6 +1,6 @@ -coordinates := [t, x, y, z] +def coordinates := [t, x, y, z] -metric := +def metric := generateTensor (\match as (integer, integer) with | (#1, #1) -> -1 diff --git a/lib/math/no-normalize.egi b/lib/math/no-normalize.egi new file mode 100644 --- /dev/null +++ b/lib/math/no-normalize.egi @@ -0,0 +1,7 @@ +-- +-- +-- Term Rewriting +-- +-- + +def mathNormalize := id diff --git a/lib/math/normalize.egi b/lib/math/normalize.egi --- a/lib/math/normalize.egi +++ b/lib/math/normalize.egi @@ -4,236 +4,23 @@ -- -- ---mathNormalize := id -mathNormalize $x := +def mathNormalize $x := if isInteger x then x - else (foldr compose id (map 2#%1 (filter 2#(%2 x) rewriteRules))) x - -rewriteRules := - [ (rewriteRuleForI, 1#(containSymbol i %1)) - , (rewriteRuleForWTerm, 1#(containSymbol w %1)) - , (rewriteRuleForRtuTerm, 1#(containFunction `rtu %1)) - , (rewriteRuleForPower, 1#(containFunction `(^) %1)) - , (rewriteRuleForExp, 1#(containFunction `exp %1)) - , (rewriteRuleForWPoly, 1#(containSymbol w %1)) - , (rewriteRuleForRtuPoly, 1#(containFunction `rtu %1)) - , (rewriteRuleForSqrt, 1#(containFunction `sqrt %1)) - , (rewriteRuleForRt, 1#(containFunction `rt %1)) - , (rewriteRuleForSin, 1#(containFunction `sin %1)) - , (rewriteRuleForCos, 1#(containFunction `cos %1)) - , (rewriteRuleForLog, 1#(containFunction `log %1)) - , (rewriteRuleForCosToSin, 1#(containFunctionWithOrder `cos 2 %1)) - , (rewriteRuleForD/d, 1#True) ] - --- --- i --- -rewriteRuleForI := rewriteRuleForITerm - -rewriteRuleForITerm := 1#(mapTerms rewriteRuleForITerm' %1) - -rewriteRuleForITerm' term := - match term as mathExpr with - | $a * #i ^ (?isEven & $k) * $r -> a *' (-1) ^' quotient k 2 *' r - | $a * #i ^ $k * $r -> a *' (-1) ^' quotient k 2 *' r *' i - | _ -> term - --- --- w --- -rewriteRuleForW := 1#(compose rewriteRuleForWTerm rewriteRuleForWPoly %1) - -rewriteRuleForWTerm := 1#(mapTerms rewriteRuleForWTerm' %1) - -rewriteRuleForWPoly := 1#(mapPolys rewriteRuleForWPoly' %1) - -rewriteRuleForWTerm' term := - match term as mathExpr with - | $a * #w ^ (?(>= 3) & $k) * $r -> a *' r *' w ^' (k % 3) - | _ -> term - -rewriteRuleForWPoly' poly := - match poly as mathExpr with - | $a * #w ^ #2 * $mr + $b * #w * #mr + $pr -> - rewriteRuleForWPoly' (pr +' (-1) *' a *' mr +' (b - a) *' mr *' w) - | _ -> poly + else if containFunction `rtu x + then rewriteRuleForRtu (symbolNormalize x) + else symbolNormalize x -- -- rtu (include i and w) -- -rewriteRuleForRtu := - compose - 1#(mapTerms rewriteRuleForRtuTerm %1) - 1#(mapPolys rewriteRuleForRtuPoly %1) - -rewriteRuleForRtuTerm := 1#(mapTerms rewriteRuleForRtuTerm' %1) - -rewriteRuleForRtuPoly := 1#(mapPolys rewriteRuleForRtuPoly' %1) - -rewriteRuleForRtuTerm' term := - match term as mathExpr with - | $a * #`rtu $n ^ (?(>= n) & $k) * $r -> a *' rtu n ^' (k % n) *' r - | _ -> term - -rewriteRuleForRtuPoly' poly := - match poly as mathExpr with - | $a * #rtu $n ^ #1 * $mr + (loop $i (2, #(n - 1)) - (#a * #(rtu n) ^ #i * #mr + ...) - $pr) -> - rewriteRuleForRtuPoly' (pr +' (-1) *' a *' mr) - | _ -> poly - --- --- sqrt --- -rewriteRuleForSqrt := 1#(mapTerms rewriteRuleForSqrtTerm %1) - -rewriteRuleForSqrtTerm term := - match term as mathExpr with - | $a * #`sqrt $x * #`sqrt #x * $r -> rewriteRuleForSqrt (a *' x *' r) - | $a * #`sqrt (?isTerm & $x) * #`sqrt (?isTerm & $y) * $r -> - let d := gcd x y - (a1, x1) := fromMonomial (x / d) - (a2, y1) := fromMonomial (y / d) - in a *' d *' sqrt (a1 *' a2) *' sqrt x1 *' sqrt y1 *' r - | _ -> term - --- --- rt (include sqrt) --- -rewriteRuleForRt := 1#(mapTerms rewriteRuleForRtTerm %1) - -rewriteRuleForRtTerm term := - match term as mathExpr with - | $a * #`rt $n $x ^ (?(>= n) & $k) * $r -> - a *' x ^' quotient k n *' rt n x ^' (k % n) *' r - | _ -> term - --- --- exp --- -rewriteRuleForExp := 1#(mapTerms rewriteRuleForExpTerm %1) - -rewriteRuleForExpTerm term := - match term as mathExpr with - | $a * #`exp #0 * $r -> a *' r - | $a * #`exp #1 * $r -> a *' e *' r - | $a * #`exp (mult $x #(i * π)) * $r -> a *' (-1) ^ x *' r - | $a * #`exp $x ^ (?(>= 2) & $n) * $r -> - rewriteRuleForExp (a *' exp (x * n) *' r) - | $a * #`exp $x * #`exp $y * $r -> rewriteRuleForExp (a *' exp (x + y) *' r) - | _ -> term - --- --- log --- -rewriteRuleForLog mExpr := mapTerms f mExpr - where - f term := - match term as mathExpr with - | _ * #`log #1 * _ -> 0 - | $a * #`log #e * $mr -> a *' mr - | _ -> term - --- --- power --- -rewriteRuleForPower := 1#(mapTerms rewriteRuleForPowerTerm %1) - -rewriteRuleForPowerTerm term := - match term as mathExpr with - | $a * #`(^) #1 _ ^ _ * $r -> rewriteRuleForPower (a *' r) - | $a * #`(^) $x $y ^ (?(>= 2) & $n) * $r -> - rewriteRuleForPower (a *' x ^ (y * n) *' r) - | $a * #`(^) $x $y * #`(^) #x $z * $r -> - rewriteRuleForPower (a *' x ^ (y + z) *' r) - | _ -> term - --- --- cos, sin --- -rewriteRuleForCosAndSin := 1#(mapPolys rewriteRuleForCosAndSinPoly %1) - -rewriteRuleForCosAndSinExpr expr := - match (expr, expr) as (mathExpr, mathExpr) with - | ( ($a * #`cos $x * $mr + $pr1) / $pr2 - , ( _ * (#`cos #(x / 2) | #`sin #(x / 2)) * _ + _) / _ - | _ / (_ * (#`cos #(x / 2) | #`sin #(x / 2)) * _ + _) ) -> - rewriteRuleForCosAndSinExpr - ((a *' (cos (x / 2) ^ 2 -' sin (x / 2) ^ 2) *' mr +' pr1) /' pr2) - | ( ($a * #`sin $x * $mr + $pr1) / $pr2 - , ( _ * (#`cos #(x / 2) | #`sin #(x / 2)) * _ + _) / _ - | _ / (_ * (#`cos #(x / 2) | #`sin #(x / 2)) * _ + _) ) -> - rewriteRuleForCosAndSinExpr - ((a *' 2 *' cos (x / 2) *' sin (x / 2) *' mr +' pr1) /' pr2) - | ( $pr2 / ($a * #`cos $x * $mr + $pr1) - , ( _ * (#`cos #(x / 2) | #`sin #(x / 2)) * _ + _) / _ - | _ / (_ * (#`cos #(x / 2) | #`sin #(x / 2)) * _ + _) ) -> - rewriteRuleForCosAndSinExpr - (pr2 /' (a *' (cos (x / 2) ^ 2 -' sin (x / 2) ^ 2) *' mr +' pr1)) - | ( $pr2 / ($a * #`sin $x * $mr + $pr1) - , ( _ * (#`cos #(x / 2) | #`sin #(x / 2)) * _ + _) / _ - | _ / (_ * (#`cos #(x / 2) | #`sin #(x / 2)) * _ + _) ) -> - rewriteRuleForCosAndSinExpr - (pr2 /' (a *' 2 *' cos (x / 2) *' sin (x / 2) *' mr +' pr1)) - | _ -> expr - -rewriteRuleForCosAndSinPoly poly := - match poly as mathExpr with - | $a * #`cos $x ^ #2 * $mr + #a * #`sin #x ^ #2 * #mr + $pr -> - rewriteRuleForCosAndSinPoly (pr +' a *' mr) - | $a * $mr + #(- a) * #`sin $x ^ #2 * #mr + $pr -> - rewriteRuleForCosAndSinPoly (pr +' a *' cos x ^ 2 *' mr) - | $a * $mr + #(- a) * #`cos $x ^ #2 * #mr + $pr -> - rewriteRuleForCosAndSinPoly (pr +' a *' sin x ^ 2 *' mr) - | _ -> poly - -rewriteRuleForCosToSin := 1#(mapTerms rewriteRuleForCosToSinTerm' %1) - -rewriteRuleForCosToSinTerm' term := - match term as mathExpr with - | $a * #`cos $x ^ #2 * $mr -> - a *' (1 -' sin x ^ 2) *' rewriteRuleForCosToSinTerm' mr - | _ -> term - -rewriteRuleForSin mExpr := mapTerms f mExpr - where - f term := - match term as mathExpr with - | _ * #`sin #0 * _ -> 0 - | _ * #`sin (mult _ #π) * _ -> 0 - | $a * #`sin (mult $n #π / #2) * $mr -> - a *' (-1) ^ ((abs n - 1) / 2) *' mr - | _ -> term - -rewriteRuleForCos mExpr := mapTerms f mExpr +def rewriteRuleForRtu := mapPolys rewriteRuleForRtuPoly where - f term := - match term as mathExpr with - | $a * #`cos #0 * $mr -> a *' mr - | $a * #`cos (term $n [#π]) * $mr -> a *' (-1) ^ abs n *' mr - | _ * #`cos (mult _ #π / #2) * _ -> 0 - | _ -> term - --- --- d --- -rewriteRuleForD := 1#(mapTerms rewriteRuleForDTerm %1) - -rewriteRuleForDTerm term := - match term as mathExpr with - | _ * #d _ * #d _ * _ -> 0 - | _ -> term - --- --- d/d --- -rewriteRuleForD/d := 1#(mapPolys rewriteRuleForD/dPoly %1) - -rewriteRuleForD/dPoly poly := - match poly as mathExpr with - | $a * ($f & (func $g _ $arg $js)) ^ $n * $mr + - $b * func #g _ #arg ?1#(eqAs (multiset something) js %1) ^ #n * #mr + $pr -> - rewriteRuleForD/dPoly ((a + b) *' f ^ n *' mr +' pr) - | _ -> poly + rewriteRuleForRtuPoly := mapPolys rewriteRuleForRtuPoly' + rewriteRuleForRtuPoly' poly := + match poly as mathExpr with + | $a * #rtu $n ^ #1 * $mr + (loop $i (2, #(n - 1)) + (#a * #(rtu n) ^ #i * #mr + ...) + $pr) -> + rewriteRuleForRtuPoly' (pr +' (-1) *' a *' mr) + | _ -> poly diff --git a/sample/bellman-ford.egi b/sample/bellman-ford.egi new file mode 100644 --- /dev/null +++ b/sample/bellman-ford.egi @@ -0,0 +1,20 @@ +-- initiate a distance graph +def A := + [|[|0, 19, 36, 66, 99, 65|] + , [|19, 0, 25, 59, 64, 31|] + , [|36, 25, 0, 84, 48, 28|] + , [|66, 59, 84, 0, 59, 29|] + , [|99, 64, 48, 59, 0, 9|] + , [|65, 31, 28, 29, 9, 0|]|] + +def G.* t1 t2 := withSymbols [i] + reduce min (contract (t1~#_i + t2~i_#)) + +match iterate (\P -> G.* P A) A as list something with + | _ ++ $P :: #P :: _ -> P +-- [|[| 0, 19, 36, 66, 59, 50 |] +-- [| 19, 0, 25, 59, 40, 31 |] +-- [| 36, 25, 0, 57, 37, 28 |] +-- [| 66, 59, 57, 0, 38, 29 |] +-- [| 59, 40, 37, 38, 0, 9 |] +-- [| 50, 31, 28, 29, 9, 0 |]|] diff --git a/sample/chopsticks.egi b/sample/chopsticks.egi --- a/sample/chopsticks.egi +++ b/sample/chopsticks.egi @@ -1,4 +1,4 @@ -assocMultiset a := matcher +def assocMultiset a := matcher | [] as () with | [] -> [()] | _ -> [] @@ -28,30 +28,30 @@ | $x :: $rs -> (x,rs)) [(2, [(1, 2), (3, 3)]), (1, [(1, 1), (2, 1), (3, 3)]), (3, [(1, 2), (2, 1), (3, 2)])] -assocToList xs := concat (matchAllDFS xs as list (something, integer) with +def assocToList xs := concat (matchAllDFS xs as list (something, integer) with | _ ++ ($x, $n) :: _ -> take n (repeat1 x)) assertEqual "assocToList" (assocToList [(1,2),(2,1),(3,3)]) [1, 1, 2, 3, 3, 3] -N := 5 +def N := 5 -tree a := matcher +def tree a := matcher | node $ $ as (a, multiset (tree a)) with | Node $x $ts -> [(x, ts)] | $ as something with | $tgt -> [tgt] -state := (integer, assocMultiset integer, assocMultiset integer) +def state := (integer, assocMultiset integer, assocMultiset integer) -fOrS s := match s as state with +def fOrS s := match s as state with | ($h, _, _) -> h -transformState s := match s as state with +def transformState s := match s as state with | ($h, $x, $y) -> (h, assocToList x, assocToList y) -move s := matchAllDFS s as state with +def move s := matchAllDFS s as state with -- equal or less than N | (#1, ($s1 & $x :: _), (?(\y -> x + y < N + 1) & $y) :: $rs') -> (2, s1, add (x + y) rs') @@ -71,7 +71,7 @@ | (#2, $x :: (![] & $rs'), (?(\y -> x + y > N) :: _) & $s2) -> (1, rs', s2) -add x xs := matchDFS xs as list (integer, integer) with +def add x xs := matchDFS xs as list (integer, integer) with | $hs ++ (#x, $n) :: $ts -> hs ++ (x, n + 1) :: ts | $hs ++ (!((?(\y -> x > y), _) :: _) & $ts) -> hs ++ (x, 1) :: ts | _ -> (x, 1) :: xs @@ -90,13 +90,13 @@ (add 2 [(1,3),(3,1)]) [(1, 3), (2, 1), (3, 1)] -init := (1, [(1,2)], [(1,2)]) +def init := (1, [(1,2)], [(1,2)]) assertEqual "move" (move init) [(2, [(1, 2)], [(1, 1), (2, 1)])] -makeTree x := Node x (map makeTree (move x)) +def makeTree x := Node x (map makeTree (move x)) assertEqual "makeTree" (makeTree (1, [(2, 1)], [(1, 1)])) @@ -106,7 +106,7 @@ [Node (-1, [(5, 1)], []) []]]]) -topTree s n := +def topTree s n := matchAllDFS makeTree s as tree state with | loop $i (1, [1..n], $m) (node $x_i (... :: _)) @@ -114,7 +114,7 @@ -> map (\i -> x_i) [1..m] -paths := +def paths := matchAllDFS makeTree init as tree state with | loop $i (1, $n) (node $x_i (... :: _)) @@ -123,7 +123,7 @@ --io (each (compose show print) (head paths)) -winningRec s := +def winningRec s := matchAll makeTree s as tree state with | (node ($h, _, _) ((node ($t & ((#(neg h), _, _) @@ -131,7 +131,7 @@ :: _)) -> t -winningNot s := +def winningNot s := matchAllDFS makeTree s as tree state with | node ($h, _, _) (loop $i (1, [1..], _) @@ -139,7 +139,7 @@ (node (#(neg h), _, _) _ :: _)) -> t -winning c := +def winning c := matchAllDFS makeTree c as tree state with | node ($h, _, _) (loop $i (1, $n) diff --git a/sample/chopsticks2.egi b/sample/chopsticks2.egi --- a/sample/chopsticks2.egi +++ b/sample/chopsticks2.egi @@ -1,4 +1,4 @@ -paths := +def paths := [[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [1, 4], [2, 2]), (2, [1, 4], [2]), (1, [1], [2]), (2, [1], [3]), (1, [4], [3]), (-1, [4], [])] ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [1, 4], [2, 2]), (2, [1, 4], [2]), (1, [3, 4], [2]), (-1, [3, 4], [])] ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [1, 4], [2, 2]), (2, [1, 4], [2]), (1, [3, 4], [2]), (2, [3, 4], [5]), (1, [3], [5]), (-1, [3], [])] @@ -23,9 +23,9 @@ ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 3], [1, 2]), (2, [1, 3], [2, 2]), (1, [3, 3], [2, 2]), (2, [3, 3], [2, 5]), (1, [3, 5], [2, 5]), (2, [3, 5], [5]), (1, [5], [5]), (-1, [5], [])] ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 3], [1, 2]), (2, [1, 3], [2, 2]), (1, [3, 3], [2, 2]), (2, [3, 3], [2, 5]), (1, [3], [2, 5]), (2, [3], [2]), (1, [5], [2]), (-1, [5], [])]] -paths2 := map (\p -> take 3 p) paths +def paths2 := map (\p -> take 3 p) paths -listToTree ps := matchDFS ps as list (list eq) with +def listToTree ps := matchDFS ps as list (list eq) with | [] :: [] -> [] | loop $i (1, $m) (($x_i :: $r_i_1) :: (loop $j (2, $n_i) diff --git a/sample/demo1-ja.egi b/sample/demo1-ja.egi --- a/sample/demo1-ja.egi +++ b/sample/demo1-ja.egi @@ -1,5 +1,5 @@ -- 素数の無限リストから全ての双子素数をパターンマッチにより抽出 -twinPrimes := +def twinPrimes := matchAll primes as list integer with | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2) diff --git a/sample/demo1.egi b/sample/demo1.egi --- a/sample/demo1.egi +++ b/sample/demo1.egi @@ -1,5 +1,5 @@ -- Extract all twin primes from the infinite list of prime numbers with pattern matching! -twinPrimes := +def twinPrimes := matchAll primes as list integer with | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2) diff --git a/sample/generalized-sequential-pattern-mining.egi b/sample/generalized-sequential-pattern-mining.egi --- a/sample/generalized-sequential-pattern-mining.egi +++ b/sample/generalized-sequential-pattern-mining.egi @@ -6,32 +6,32 @@ -- Configuration -- -items := [a, b, c, d, e, f] +def items := [a, b, c, d, e, f] -ISDB := +def ISDB := [[[(0, [a]), (86400, [a, b, c]), (259200, [a, c])]] ,[[(0, [a, d]), (259200, [c])]] ,[[(0, [a, e, f]), (172800, [a, b])]]] -N := length ISDB -minSup := ceiling (0.5 * N) +def N := length ISDB +def minSup := ceiling (0.5 * N) -C1 := 0 -- min_interval -C2 := 172800 -- max_interval -C3 := 0 -- min_whole_interval -C4 := 300000 -- max_whole_interval +def C1 := 0 -- min_interval +def C2 := 172800 -- max_interval +def C3 := 0 -- min_whole_interval +def C4 := 300000 -- max_whole_interval -I t := floor (rtof (t / (60 * 60 * 24))) +def I t := floor (rtof (t / (60 * 60 * 24))) -- -- Utils -- -query := list (integer, eq) +def query := list (integer, eq) -sequence := list (time, list eq) +def sequence := list (time, list eq) -time := matcher +def time := matcher | interval $ $ as (integer, integer) with | $t -> [(I t, t)] | $ as something with @@ -43,13 +43,13 @@ -- -- calculate ISDB|α -project α ISDB := match α as query with +def project α ISDB := match α as query with | (#0, $x) :: $α' -> project' α' (map (\xss -> matchAllDFS xss as set sequence with | (_ ++ ($t, _ ++ #x :: $cs) :: $ls) :: _ -> (0, cs) :: (map (\t' xs -> (t' - t, xs)) ls)) ISDB) -project' α ISDB := match α as query with +def project' α ISDB := match α as query with | [] -> ISDB | ($a, $x) :: $α' -> project' (map (\b y -> (b - a, y)) α') (map (\xss -> matchAllDFS xss as set sequence with @@ -58,7 +58,7 @@ ISDB) -- main function -gspm items ISDB I minSup C1 C2 C3 C4 := +def gspm items ISDB I minSup C1 C2 C3 C4 := let φ := [] in let R := [] in let fs := filter (\α ISDB' -> match ISDB' as multiset sequence with @@ -68,7 +68,7 @@ let iss := map (\α ISDB' -> α) fs in iss ++ concat (map (\α ISDB' -> projection α ISDB' I minSup C1 C2 C3 C4) fs) -projection α ISDB' I minSup C1 C2 C3 C4 := +def projection α ISDB' I minSup C1 C2 C3 C4 := let fs := filter (\a t x -> C1 <= t && t <= C2) (freqItem ISDB' minSup C1 C2 C3 C4) in let iss' := map (\a t x -> α ++ [(a, x)]) fs in -- TODO: apply C4 @@ -76,7 +76,7 @@ iss' ++ concat (map (\α' -> projection α' (project α' ISDB) I minSup C1 C2 C3 C4) iss') -freqItem ISDB minSup C1 C2 C3 C4 := +def freqItem ISDB minSup C1 C2 C3 C4 := matchAll ISDB as list (list sequence) with | first (interval $a $t) $x (loop $i (2, minSup) @@ -84,7 +84,7 @@ !(first (interval #a _) #x _)) -> (a, t, x) -first := \pt px ps => +def first := \pt px ps => {@ ++ (@ ++ (@ ++ ((interval $t _ & ~pt), _ ++ ($x & ~px) :: _) :: _) :: _) :: @, (!(_ ++ (_ ++ (_ ++ (interval #t _, _ ++ #x :: _) :: _) :: _) :: _), !(_ ++ (_ ++ (interval #t _, _ ++ #x :: _) :: _) :: _), diff --git a/sample/graph.egi b/sample/graph.egi new file mode 100644 --- /dev/null +++ b/sample/graph.egi @@ -0,0 +1,60 @@ +-- +-- +-- Graph demonstration +-- +-- + +-- +-- Matcher definition +-- +def graph $a := set (edge a) + +def edge $a := + algebraicDataMatcher + | edge a a + +-- +-- Sample data +-- +def graphData1 := + [Edge 1 4, Edge 2 1, Edge 3 1, Edge 3 2, Edge 4 3, Edge 5 1, Edge 5 4] + +def graphData2 := + [Edge 1 4, Edge 1 5, Edge 1 8, Edge 1 10, Edge 2 3, Edge 2 6, Edge 2 12, + Edge 3 2, Edge 3 7, Edge 3 9, Edge 4 1, Edge 4 6, Edge 5 1, Edge 5 8, + Edge 5 9, Edge 5 11, Edge 6 2, Edge 6 4, Edge 6 10, Edge 6 12, Edge 7 3, + Edge 7 9, Edge 7 11, Edge 8 1, Edge 8 5, Edge 9 3, Edge 9 5, Edge 9 7, + Edge 10 1, Edge 10 6, Edge 10 12, Edge 11 5, Edge 11 7, Edge 12 2, Edge 12 6, + Edge 12 10] + +-- +-- Demonstration code +-- +-- find all nodes who have an edge from 's' but not have an edge to 's' +let s := 1 + in matchAll graphData1 as graph integer with + | edge #s $x :: !(edge #x #s :: _) -> x + +-- find all nodes in two paths from 's' +let s := 1 + in matchAll graphData1 as graph integer with + | edge (#s & $x_1) $x_2 :: edge #x_2 $x_3 :: _ -> x + +-- enumerate first 5 paths from 's' to 'e' +take + 5 + (let s := 1 + e := 2 + in matchAll graphData2 as graph integer with + | edge (#s & $x_1) $x_2 :: (loop $i (4, $n) + (edge #x_(i - 2) $x_(i - 1) :: ...) + (edge #x_(n - 1) (#e & $x_n) :: _)) -> x) + +-- find all cliques whose size is 'n' +let n := 3 + in matchAll graphData2 as graph integer with + | edge $x_1 $x_2 :: (loop $i (3, n, _) + (edge #x_1 $x_i :: (loop $j (2, i - 1, _) + (edge #x_j #x_i :: ...) + ...)) + _) -> x diff --git a/sample/ioRef.egi b/sample/ioRef.egi --- a/sample/ioRef.egi +++ b/sample/ioRef.egi @@ -1,4 +1,4 @@ -refTest x y := +def refTest x y := do let w := newIORef () writeIORef w x let w1 := readIORef w @@ -8,4 +8,4 @@ print (show w2) flush () -main args := refTest 1 2 +def main args := refTest 1 2 diff --git a/sample/mahjong.egi b/sample/mahjong.egi --- a/sample/mahjong.egi +++ b/sample/mahjong.egi @@ -7,13 +7,13 @@ -- -- Matcher definitions -- -suit := +def suit := algebraicDataMatcher | wan | pin | sou -honor := +def honor := algebraicDataMatcher | ton | nan @@ -23,7 +23,7 @@ | hatsu | chun -tile := +def tile := algebraicDataMatcher | num suit integer | hnr honor @@ -31,18 +31,18 @@ -- -- Pattern modularization -- -twin := \pat1 pat2 => ($pat & ~pat1) :: #pat :: ~pat2 +def twin := \pat1 pat2 => ($pat & ~pat1) :: #pat :: ~pat2 -shuntsu := +def shuntsu := \pat1 pat2 => (num $s $n & ~pat1) :: num #s #(n + 1) :: num #s #(n + 2) :: ~pat2 -kohtsu := \pat1 pat2 => ($pat & ~pat1) :: #pat :: #pat :: ~pat2 +def kohtsu := \pat1 pat2 => ($pat & ~pat1) :: #pat :: #pat :: ~pat2 -- -- A function that determines whether the hand is completed or not. -- -complete? := +def complete? := \match as multiset tile with | twin $th_1 diff --git a/sample/math/geometry/curvature-form.egi b/sample/math/geometry/curvature-form.egi --- a/sample/math/geometry/curvature-form.egi +++ b/sample/math/geometry/curvature-form.egi @@ -1,16 +1,16 @@ -- Parameters and metric tensor -x := [| θ, φ |] +def x := [| θ, φ |] -g_i_j := [| [| r^2, 0 |], [| 0, r^2 * (sin θ)^2 |] |]_i_j -g~i~j := [| [| 1 / r^2, 0 |], [| 0, 1 / (r^2 * (sin θ)^2) |] |]~i~j +def g_i_j := [| [| r^2, 0 |], [| 0, r^2 * (sin θ)^2 |] |]_i_j +def g~i~j := [| [| 1 / r^2, 0 |], [| 0, 1 / (r^2 * (sin θ)^2) |] |]~i~j -- Christoffel symbols -Γ_j_l_k := (1 / 2) * (∂/∂ g_j_l x~k + ∂/∂ g_j_k x~l - ∂/∂ g_k_l x~j) +def Γ_j_l_k := (1 / 2) * (∂/∂ g_j_l x~k + ∂/∂ g_j_k x~l - ∂/∂ g_k_l x~j) -Γ~i_k_l := withSymbols [j] g~i~j . Γ_j_l_k +def Γ~i_k_l := withSymbols [j] g~i~j . Γ_j_l_k -- Riemann curvature -R~i_j_k_l := withSymbols [m] +def R~i_j_k_l := withSymbols [m] ∂/∂ Γ~i_j_l x~k - ∂/∂ Γ~i_j_k x~l + Γ~m_j_l . Γ~i_m_k - Γ~m_j_k . Γ~i_m_l assertEqual "Riemann curvature" R~#_#_1_1 [| [| 0, 0 |], [| 0, 0 |] |]~#_# @@ -19,18 +19,18 @@ assertEqual "Riemann curvature" R~#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]~#_# -- Exterior derivative -d %t := !(flip ∂/∂) x t +def d %t := !(flip ∂/∂) x t -- Wedge product infixl expression 7 ∧ -(∧) %x %y := x !. y +def (∧) %x %y := x !. y -- Connection form -ω~i_j := Γ~i_j_# +def ω~i_j := Γ~i_j_# -- Curvature form -Ω~i_j := withSymbols [k] +def Ω~i_j := withSymbols [k] antisymmetrize (d ω~i_j + ω~i_k ∧ ω~k_j) assertEqual "Curvature form" Ω~#_#_1_1 [| [| 0, 0 |], [| 0, 0 |] |]~#_# diff --git a/sample/math/geometry/hodge-laplacian-polar.egi b/sample/math/geometry/hodge-laplacian-polar.egi --- a/sample/math/geometry/hodge-laplacian-polar.egi +++ b/sample/math/geometry/hodge-laplacian-polar.egi @@ -1,34 +1,34 @@ -- Parameters and metrics -N := 2 +def N := 2 -x := [|r, θ|] +def x := [|r, θ|] -g_i_j := [| [| 1, 0 |], [| 0, r^2 |] |]_i_j -g~i~j := [| [| 1, 0 |], [| 0, 1 / r^2 |] |]~i~j +def g_i_j := [| [| 1, 0 |], [| 0, r^2 |] |]_i_j +def g~i~j := [| [| 1, 0 |], [| 0, 1 / r^2 |] |]~i~j -- Hodge Laplacian -d %A := !(flip ∂/∂) x A +def d %A := !(flip ∂/∂) x A -hodge %A := +def hodge %A := let k := dfOrder A in withSymbols [i, j] (sqrt (abs (M.det g_#_#))) * (foldl (.) ((ε' N k)_(i_1)..._(i_N) . A..._(j_1)..._(j_k)) (map 1#g~(i_%1)~(j_%1) [1..k])) -δ %A := +def δ %A := let k := dfOrder A in -1^(N * (k + 1) + 1) * (hodge (d (hodge A))) -Δ %A := +def Δ %A := match (dfOrder A) as integer with | #0 -> δ (d A) | #N -> d (δ A) | _ -> d (δ A) + δ (d A) -f := function (r, θ) +def f := function (r, θ) assertEqual "exterior derivative" (d f) [| ∂/∂ f r, ∂/∂ f θ |] 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 @@ -1,16 +1,16 @@ -- Parameters -x := [| θ, φ |] +def x := [| θ, φ |] -X := [| r * sin θ * cos φ -- x - , r * sin θ * sin φ -- y - , r * cos θ -- z - |] +def X := [| r * sin θ * cos φ -- x + , r * sin θ * sin φ -- y + , r * cos θ -- z + |] -e_i_j := ∂/∂ X_j x~i +def e_i_j := ∂/∂ X_j x~i -- Metric tensors -g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2] -g~i~j := M.inverse g_#_# +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_#_# @@ -20,7 +20,7 @@ [| [| 1 / r^2, 0 |], [| 0, 1 / (r^2 * (sin θ)^2) |] |]~#~# -- Christoffel symbols -Γ_i_j_k := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i) +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_#_# @@ -29,7 +29,7 @@ Γ_2_#_# [| [| 0, r^2 * (sin θ) * (cos θ) |], [| r^2 * (sin θ) * (cos θ), 0 |] |]_#_# -Γ~i_j_k := withSymbols [m] +def Γ~i_j_k := withSymbols [m] g~i~m . Γ_m_j_k assertEqual "Christoffel symbols of the second kind" @@ -40,7 +40,7 @@ [| [| 0, (cos θ) / (sin θ) |], [| (cos θ) / (sin θ), 0 |] |]_#_# -- Riemann curvature -R~i_j_k_l := withSymbols [m] +def R~i_j_k_l := withSymbols [m] ∂/∂ Γ~i_j_l x~k - ∂/∂ Γ~i_j_k x~l + Γ~m_j_l . Γ~i_m_k - Γ~m_j_k . Γ~i_m_l assertEqual "riemann curvature" @@ -57,11 +57,11 @@ [| [| 0, 0 |], [| 0, 0 |] |]~#_# -- Ricci curvature -Ric_i_j := withSymbols [m] +def Ric_i_j := withSymbols [m] sum (contract R~m_i_m_j) -- Scalar curvature -scalarCurvature := withSymbols [i, j] +def scalarCurvature := withSymbols [i, j] g~i~j . Ric_i_j assertEqual "scalar curvature" 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 new file mode 100644 --- /dev/null +++ b/sample/math/geometry/riemann-curvature-tensor-of-S5-non-sym.egi @@ -0,0 +1,54 @@ +-- Parameters +def x := [|θ, φ, ψ, η, δ|] + +def X := [| r * (cos θ), + r * (sin θ) * (cos φ), + r * (sin θ) * (sin φ) * (cos ψ), + r * (sin θ) * (sin φ) * (sin ψ) * (cos η), + r * (sin θ) * (sin φ) * (sin ψ) * (sin η) * (cos δ), + r * (sin θ) * (sin φ) * (sin ψ) * (sin η) * (sin δ) |] + +-- Local basis +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 := M.inverse g_#_# + +-- Christoffel symbols +def Γ_i_j_k := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i) + +def Γ~i_j_k := withSymbols [m] + g~i~m . Γ_m_j_k + +-- Riemann curvature +def R~i_j_k_l := withSymbols [m] + ∂/∂ Γ~i_j_l x~k - ∂/∂ Γ~i_j_k x~l + Γ~m_j_l . Γ~i_m_k - Γ~m_j_k . Γ~i_m_l + +--R~#_#_#_# + +--def R_a_b_c_d := withSymbols [i] g_a_i . R~i_b_c_d + +-- Ricci curvature +def Ric_a_b := withSymbols [m, n] + sum (contract (R~m_a_m_b)) + +Ric_#_# + +-- Scalar curvature +def scalarCurvature := withSymbols [i, j] + g~i~j . Ric_i_j + +-- Conformal curvature tensor +def C_i_k_l_m := R_i_k_l_m + + (Ric_i_m . g_k_l - Ric_i_l . g_k_m + Ric_k_l . g_i_m - Ric_k_m . g_i_l) + + (scalarCurvature / 2) * (g_i_l . g_k_m - g_i_m . g_k_l) +--C_#_#_#_# + +-- Wodzicki-Chern-Simons class +def S := + let (es, os) := evenAndOddPermutations 5 in + sum (map (\σ -> R~u_1_s_(σ 1) . R~s_t_(σ 3)_(σ 2) . R~t_u_(σ 5)_(σ 4)) es) - + sum (map (\σ -> R~u_1_s_(σ 1) . R~s_t_(σ 3)_(σ 2) . R~t_u_(σ 5)_(σ 4)) os) + +--S diff --git a/sample/math/geometry/riemann-curvature-tensor-of-S5.egi b/sample/math/geometry/riemann-curvature-tensor-of-S5.egi new file mode 100644 --- /dev/null +++ b/sample/math/geometry/riemann-curvature-tensor-of-S5.egi @@ -0,0 +1,54 @@ +-- Parameters +def x := [|θ, φ, ψ, η, δ|] + +def X := [| r * (cos θ), + r * (sin θ) * (cos φ), + r * (sin θ) * (sin φ) * (cos ψ), + r * (sin θ) * (sin φ) * (sin ψ) * (cos η), + r * (sin θ) * (sin φ) * (sin ψ) * (sin η) * (cos δ), + r * (sin θ) * (sin φ) * (sin ψ) * (sin η) * (sin δ) |] + +-- Local basis +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} := M.inverse g_#_# + +-- Christoffel symbols +def Γ_i[_j_k] := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i) + +def Γ~i[_j_k] := withSymbols [m] + g~i~m . Γ_m_j_k + +-- Riemann curvature +def R~i_j[_k_l] := withSymbols [m] + ∂/∂ Γ~i_j_l x~k - ∂/∂ Γ~i_j_k x~l + Γ~m_j_l . Γ~i_m_k - Γ~m_j_k . Γ~i_m_l + +--R~#_#_#_# + +--def R{[_a_b][_c_d]} := withSymbols [i] g_a_i . R~i_b_c_d + +-- Ricci curvature +def Ric[_a_b] := withSymbols [m, n] + sum (contract (R~m_a_m_b)) + +Ric_#_# -- 7.422 sec + +-- Scalar curvature +def scalarCurvature := withSymbols [i, j] + g~i~j . Ric_i_j + +-- Conformal curvature tensor +def C_i_k_l_m := R_i_k_l_m + + (Ric_i_m . g_k_l - Ric_i_l . g_k_m + Ric_k_l . g_i_m - Ric_k_m . g_i_l) + + (scalarCurvature / 2) * (g_i_l . g_k_m - g_i_m . g_k_l) +--C_#_#_#_# + +-- Wodzicki-Chern-Simons class +def S := + let (es, os) := evenAndOddPermutations 5 in + sum (map (\σ -> R~u_1_s_(σ 1) . R~s_t_(σ 3)_(σ 2) . R~t_u_(σ 5)_(σ 4)) es) - + sum (map (\σ -> R~u_1_s_(σ 1) . R~s_t_(σ 3)_(σ 2) . R~t_u_(σ 5)_(σ 4)) os) + +--S -- 0 -- 16.957 sec 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 new file mode 100644 --- /dev/null +++ b/sample/math/geometry/riemann-curvature-tensor-of-T2-non-sym.egi @@ -0,0 +1,85 @@ +-- Parameters +def x := [| θ, φ |] + +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 := M.inverse g_#_# + +assertEqual "Metric tensor" + g_#_# + [| [| a^2, 0 |], [| 0, '(a * cos θ + b)^2 |] |]_#_# +assertEqual "Metric tensor" + g~#~# + [| [| 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 θ |] |]_#_# +assertEqual "Christoffel symbols of the first kind" + Γ_2_#_# + [| [| 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 |] |]_#_# +assertEqual "Christoffel symbols of the second kind" + Γ~2_#_# + [| [| 0, -1 * a * sin θ / '(a * cos θ + b) |], [| -1 * a * sin θ / '(a * cos θ + b), 0 |] |]_#_# + +-- Riemann curvature +def R~i_j_k_l := withSymbols [m] + ∂/∂ Γ~i_j_l x~k - ∂/∂ Γ~i_j_k x~l + Γ~m_j_l . Γ~i_m_k - Γ~m_j_k . Γ~i_m_l + +assertEqual "riemann curvature" + R~#_#_1_1 + [| [| 0, 0 |], [| 0, 0 |] |]~#_# +assertEqual "riemann curvature" + R~#_#_1_2 + [| [| 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 |] |]~#_# +assertEqual "riemann curvature" + R~#_#_2_2 + [| [| 0, 0 |], [| 0, 0 |] |]~#_# + +-- Riemann curvature 2 +def R_i_j_k_l := withSymbols [m] g_i_m . R~m_j_k_l + +assertEqual "riemann curvature" + R_#_#_1_1 + [| [| 0, 0 |], [| 0, 0 |] |]_#_# +assertEqual "riemann curvature" + R_#_#_1_2 + [| [| 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 |] |]_#_# +assertEqual "riemann curvature" + R_#_#_2_2 + [| [| 0, 0 |], [| 0, 0 |] |]_#_# + +-- Ricci curvature +def Ric_i_j := withSymbols [m] + sum (contract R~m_i_m_j) + +-- Scalar curvature +def scalarCurvature := withSymbols [i, j] + g~i~j . Ric_i_j + +assertEqual "scalar curvature" + scalarCurvature + (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,16 +1,16 @@ -- Parameters -x := [| θ, φ |] +def x := [| θ, φ |] -X := [| '(a * cos θ + b) * cos φ -- x - , '(a * cos θ + b) * sin φ -- y - , a * sin θ -- z - |] +def X := [| '(a * cos θ + b) * cos φ -- x + , '(a * cos θ + b) * sin φ -- y + , a * sin θ -- z + |] -e_i_j := ∂/∂ X_j x~i +def e_i_j := ∂/∂ X_j x~i -- Metric tensors -g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2] -g~i~j := M.inverse g_#_# +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_#_# @@ -20,7 +20,7 @@ [| [| 1 / a^2, 0 |], [| 0, 1 / '(a * cos θ + b)^2 |] |]~#~# -- Christoffel symbols -Γ_i_j_k := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i) +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_#_# @@ -29,7 +29,7 @@ Γ_2_#_# [| [| 0, -1 * '(a * cos θ + b) * a * sin θ |], [| -1 * '(a * cos θ + b) * a * sin θ, 0 |] |]_#_# -Γ~i_j_k := withSymbols [m] +def Γ~i{_j_k} := withSymbols [m] g~i~m . Γ_m_j_k assertEqual "Christoffel symbols of the second kind" @@ -40,7 +40,7 @@ [| [| 0, -1 * a * sin θ / '(a * cos θ + b) |], [| -1 * a * sin θ / '(a * cos θ + b), 0 |] |]_#_# -- Riemann curvature -R~i_j_k_l := withSymbols [m] +def R~i_j_k_l := withSymbols [m] ∂/∂ Γ~i_j_l x~k - ∂/∂ Γ~i_j_k x~l + Γ~m_j_l . Γ~i_m_k - Γ~m_j_k . Γ~i_m_l assertEqual "riemann curvature" @@ -56,12 +56,28 @@ R~#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]~#_# +-- Riemann curvature 2 +def R{[_i_j][_k_l]} := withSymbols [m] g_i_m . R~m_j_k_l + +assertEqual "riemann curvature" + R_#_#_1_1 + [| [| 0, 0 |], [| 0, 0 |] |]_#_# +assertEqual "riemann curvature" + R_#_#_1_2 + [| [| 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 |] |]_#_# +assertEqual "riemann curvature" + R_#_#_2_2 + [| [| 0, 0 |], [| 0, 0 |] |]_#_# + -- Ricci curvature -Ric_i_j := withSymbols [m] +def Ric[_i_j] := withSymbols [m] sum (contract R~m_i_m_j) -- Scalar curvature -scalarCurvature := withSymbols [i, j] +def scalarCurvature := withSymbols [i, j] g~i~j . Ric_i_j assertEqual "scalar curvature" diff --git a/sample/math/geometry/thurston-non-sym.egi b/sample/math/geometry/thurston-non-sym.egi new file mode 100644 --- /dev/null +++ b/sample/math/geometry/thurston-non-sym.egi @@ -0,0 +1,89 @@ +--- +--- Calculation of the WCS Invariant on the Thurston Example (Section 4) +--- + +def x~i := [| θ₁, θ₂, θ₃, θ₄ |]~i + +def g_i_j := + [|[| 1, 0, 0, 0 |], + [| 0, 1, 0, 0 |], + [| 0, 0, κ / (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, θ₂ / ((sqrt β) * κ), 1 / ((sqrt β) * κ) |]|] + +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) + +def R_i_j_k~l := withSymbols [a] + ∂/∂ Γ~l_j_k x~i - ∂/∂ Γ~l_i_k x~j + Γ~l_i_a . Γ~a_j_k - Γ~l_j_a . Γ~a_i_k + +def R_i_j_k_l := withSymbols [a] R_i_j_k~a . g_a_l + +def J_a_b := + [|[| 0, 1, 0, 0 |], + [| -1, 0, 0, 0 |], + [| 0, 0, 0, κ |], + [| 0, 0, -1 * κ, 0 |]|] + +def J_a~c := J_a_b . g~b~c + +def ∇J_m_a_b := + withSymbols [n] + ∂/∂ J_a_b x~m + Γ~n_m_a . J_n_b + Γ~n_m_b . J_a_n + +def ∇J~m_a_b := + withSymbols [t] + ∇J_t_a_b . g~t~m + +def ∇J_m~a_b := + withSymbols [t] + ∇J_m_t_b . g~t~a + +def ∇J_m_a~b := + withSymbols [t] + ∇J_m_a_t . g~t~b + +def δ := + generateTensor + (\x y -> match (x, y) as (integer, 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) + + -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)) + [5, 5, 5, 5] + +def S := + withSymbols [i, j, k] + let (es, os) := evenAndOddPermutations 5 in + sum (map (\$σ -> R'_(σ 1)_j_1~i . R'_(σ 2)_(σ 3)_k~j . R'_(σ 4)_(σ 5)_i~k) es) - + sum (map (\$σ -> R'_(σ 1)_j_1~i . R'_(σ 2)_(σ 3)_k~j . R'_(σ 4)_(σ 5)_i~k) os) + +S +-- After 10 seconds calculation, we can get the following result: +-- (1536 p^6 κ Sqrt[(1 + θ₂ - θ₂^2)]^16 - 1536 p^6 θ₂^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^14 - 576 p^4 (1 + θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^12 + 1536 p^6 (1 + θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^14 + 8 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^3 θ₂^2 κ - 88 p^2 (1 - 2 θ₂)^2 (1 + θ₂)^2 θ₂^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ + 48 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^2 θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 12 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^2 θ₂^4 κ - 24 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^2 θ₂^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^2 + 288 p^4 (1 - 2 θ₂)^2 (1 + θ₂)^2 θ₂^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^6 - 160 p^2 (1 - 2 θ₂) (1 + θ₂) θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^6 κ + 128 p^2 (1 - 2 θ₂)^2 (1 + θ₂) θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ - 48 p^2 (1 - 2 θ₂)^3 (1 + θ₂) θ₂^5 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 80 p^2 (1 - 2 θ₂)^2 (1 + θ₂) θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ + 768 p^4 (1 - 2 θ₂) (1 + θ₂) θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^8 κ + 8 p^2 (1 - 2 θ₂)^4 (1 + θ₂) θ₂^6 κ + 24 p^2 (1 - 2 θ₂)^3 (1 + θ₂) θ₂^4 κ Sqrt[(1 + θ₂ - θ₂^2)]^2 - 288 p^4 (1 - 2 θ₂)^2 (1 + θ₂) θ₂^4 κ Sqrt[(1 + θ₂ - θ₂^2)]^6 + 112 p^2 (1 - 2 θ₂) (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^2 κ + 20 p^2 (1 - 2 θ₂)^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^2 κ - 64 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^4 κ + 96 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^5 (1 - 2 θ₂) κ - 56 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^6 (1 - 2 θ₂)^2 κ - 80 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^4 (1 - 2 θ₂) κ + 384 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^10 θ₂^4 κ + 16 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^2 θ₂^7 (1 - 2 θ₂)^3 κ + 40 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^5 (1 - 2 θ₂)^2 κ - 384 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^5 (1 - 2 θ₂) κ + 32 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^3 κ + 24 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^3 (1 - 2 θ₂) κ - 448 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^10 θ₂^3 κ - 2 p^2 (1 - 2 θ₂)^4 θ₂^8 κ - 8 p^2 (1 - 2 θ₂)^3 θ₂^6 κ Sqrt[(1 + θ₂ - θ₂^2)]^2 + 96 p^4 (1 - 2 θ₂)^2 θ₂^6 κ Sqrt[(1 + θ₂ - θ₂^2)]^6 - 10 p^2 (1 - 2 θ₂)^2 θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ - 16 p^2 (1 + θ₂)^3 (1 - 2 θ₂)^3 Sqrt[(1 + θ₂ - θ₂^2)]^2 θ₂ κ + 64 p^2 (1 + θ₂)^2 (1 - 2 θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂ κ + 40 p^2 (1 + θ₂)^2 (1 - 2 θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂ κ - 384 p^4 (1 + θ₂)^2 (1 - 2 θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^8 κ θ₂ + 96 p^2 (1 + θ₂) θ₂^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 κ - 32 p^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂ κ - 24 p^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂ (1 - 2 θ₂) κ + 448 p^4 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^10 κ θ₂ - 32 p^2 (1 - 2 θ₂) (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 κ - 10 p^2 (1 - 2 θ₂)^2 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ + 8 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^3 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ + 16 p^2 (1 - 2 θ₂)^2 (1 + θ₂)^3 κ Sqrt[(1 + θ₂ - θ₂^2)]^4 - 2 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^4 κ - 96 p^4 (1 - 2 θ₂)^2 (1 + θ₂)^3 κ Sqrt[(1 + θ₂ - θ₂^2)]^6 + 4 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 (1 + θ₂) (1 - 2 θ₂) κ + 8 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 (1 + θ₂) κ - 112 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^10 κ (1 + θ₂) - 8 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^2 κ - 4 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^2 (1 - 2 θ₂) κ + 112 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^10 θ₂^2 κ - 48 p^2 (1 - 2 θ₂)^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂ κ + 40 p^2 (1 - 2 θ₂)^3 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^2 κ + 12 p^2 (1 - 2 θ₂)^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 κ - 20 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ + 112 p^2 (1 - 2 θ₂)^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^2 κ + 32 p^2 (1 - 2 θ₂) (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^8 κ - 32 p^2 (1 - 2 θ₂)^2 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 κ + 40 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂ κ - 21 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^2 θ₂^2 κ + 7 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^3 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 80 p^2 (1 - 2 θ₂)^3 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^3 κ + 21 p^2 (1 - 2 θ₂)^4 (1 + θ₂) θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 32 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^2 (1 - 2 θ₂) κ + 48 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^3 (1 - 2 θ₂)^2 κ - 16 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^10 θ₂^2 κ + 64 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^3 (1 - 2 θ₂) κ - 80 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^4 (1 - 2 θ₂)^2 κ + 40 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^5 (1 - 2 θ₂)^3 κ - 20 p^2 (1 - 2 θ₂)^3 θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ - 12 p^2 (1 - 2 θ₂)^2 θ₂^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 κ - 7 p^2 (1 - 2 θ₂)^4 θ₂^6 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 64 p^4 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^10 κ - 32 p^2 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 κ + 16 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^10 (1 + θ₂) κ - 64 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 (1 - 2 θ₂) θ₂ (1 + θ₂) κ + 576 p^4 θ₂ Sqrt[(1 + θ₂ - θ₂^2)]^12 κ - 144 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^12 κ - 224 p^4 (1 - 2 θ₂)^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^10 (1 + θ₂) - 384 p^4 κ (1 - 2 θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^12 θ₂ + 224 p^4 (1 - 2 θ₂)^2 θ₂^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^10 + 192 p^4 (1 - 2 θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^12 κ + 128 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^14 κ - 320 p^4 θ₂^2 Sqrt[(1 + θ₂ - θ₂^2)]^10 κ (1 + θ₂) + 128 p^4 (1 - 2 θ₂) (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^10 κ - 128 p^4 θ₂^2 (1 - 2 θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^10 + 192 p^4 (1 + θ₂)^2 (1 - 2 θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^8 - 384 p^4 θ₂^2 (1 - 2 θ₂) (1 + θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^8 + 192 p^4 θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^8 κ (1 - 2 θ₂) - 256 p^4 θ₂ Sqrt[(1 + θ₂ - θ₂^2)]^10 κ (1 - 2 θ₂) (1 + θ₂) + 256 p^4 θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^10 κ (1 - 2 θ₂) + 128 p^4 θ₂^2 (1 - 2 θ₂)^2 κ (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^8 - 64 p^4 θ₂^4 (1 - 2 θ₂)^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^8 - 64 p^4 (1 - 2 θ₂)^2 (1 + θ₂)^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^8)/(16 Sqrt[(1 + θ₂ - θ₂^2)]^16) +-- The above result is simplified using the Wolfam language as follows: +-- (p^2 (-25 - 640 p^2 (1 + θ₂- θ₂^2)^2 + 3072 p^4 (1 + θ₂ - θ₂^2)^4) κ) / (16 (1 + θ₂ - θ₂^2)^4) diff --git a/sample/math/geometry/thurston.egi b/sample/math/geometry/thurston.egi new file mode 100644 --- /dev/null +++ b/sample/math/geometry/thurston.egi @@ -0,0 +1,89 @@ +--- +--- Calculation of the WCS Invariant on the Thurston Example (Section 4) +--- + +def x~i := [| θ₁, θ₂, θ₃, θ₄ |]~i + +def g_i_j := + [|[| 1, 0, 0, 0 |], + [| 0, 1, 0, 0 |], + [| 0, 0, κ / (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, θ₂ / ((sqrt β) * κ), 1 / ((sqrt β) * κ) |]|] + +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) + +def R_i_j_k~l := withSymbols [a] + ∂/∂ Γ~l_j_k x~i - ∂/∂ Γ~l_i_k x~j + Γ~l_i_a . Γ~a_j_k - Γ~l_j_a . Γ~a_i_k + +def R_i_j_k_l := withSymbols [a] R_i_j_k~a . g_a_l + +def J_a_b := + [|[| 0, 1, 0, 0 |], + [| -1, 0, 0, 0 |], + [| 0, 0, 0, κ |], + [| 0, 0, -1 * κ, 0 |]|] + +def J_a~c := J_a_b . g~b~c + +def ∇J_m_a_b := + withSymbols [n] + ∂/∂ J_a_b x~m + Γ~n_m_a . J_n_b + Γ~n_m_b . J_a_n + +def ∇J~m_a_b := + withSymbols [t] + ∇J_t_a_b . g~t~m + +def ∇J_m~a_b := + withSymbols [t] + ∇J_m_t_b . g~t~a + +def ∇J_m_a~b := + withSymbols [t] + ∇J_m_a_t . g~t~b + +def δ := + generateTensor + (\x y -> match (x, y) as (integer, 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) + + -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)) + [5, 5, 5, 5] + +def S := + withSymbols [i, j, k] + let (es, os) := evenAndOddPermutations 5 in + sum (map (\$σ -> R'_(σ 1)_j_1~i . R'_(σ 2)_(σ 3)_k~j . R'_(σ 4)_(σ 5)_i~k) es) - + sum (map (\$σ -> R'_(σ 1)_j_1~i . R'_(σ 2)_(σ 3)_k~j . R'_(σ 4)_(σ 5)_i~k) os) + +S +-- After 10 seconds calculation, we can get the following result: +-- (1536 p^6 κ Sqrt[(1 + θ₂ - θ₂^2)]^16 - 1536 p^6 θ₂^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^14 - 576 p^4 (1 + θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^12 + 1536 p^6 (1 + θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^14 + 8 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^3 θ₂^2 κ - 88 p^2 (1 - 2 θ₂)^2 (1 + θ₂)^2 θ₂^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ + 48 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^2 θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 12 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^2 θ₂^4 κ - 24 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^2 θ₂^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^2 + 288 p^4 (1 - 2 θ₂)^2 (1 + θ₂)^2 θ₂^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^6 - 160 p^2 (1 - 2 θ₂) (1 + θ₂) θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^6 κ + 128 p^2 (1 - 2 θ₂)^2 (1 + θ₂) θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ - 48 p^2 (1 - 2 θ₂)^3 (1 + θ₂) θ₂^5 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 80 p^2 (1 - 2 θ₂)^2 (1 + θ₂) θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ + 768 p^4 (1 - 2 θ₂) (1 + θ₂) θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^8 κ + 8 p^2 (1 - 2 θ₂)^4 (1 + θ₂) θ₂^6 κ + 24 p^2 (1 - 2 θ₂)^3 (1 + θ₂) θ₂^4 κ Sqrt[(1 + θ₂ - θ₂^2)]^2 - 288 p^4 (1 - 2 θ₂)^2 (1 + θ₂) θ₂^4 κ Sqrt[(1 + θ₂ - θ₂^2)]^6 + 112 p^2 (1 - 2 θ₂) (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^2 κ + 20 p^2 (1 - 2 θ₂)^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^2 κ - 64 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^4 κ + 96 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^5 (1 - 2 θ₂) κ - 56 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^6 (1 - 2 θ₂)^2 κ - 80 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^4 (1 - 2 θ₂) κ + 384 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^10 θ₂^4 κ + 16 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^2 θ₂^7 (1 - 2 θ₂)^3 κ + 40 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^5 (1 - 2 θ₂)^2 κ - 384 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^5 (1 - 2 θ₂) κ + 32 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^3 κ + 24 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^3 (1 - 2 θ₂) κ - 448 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^10 θ₂^3 κ - 2 p^2 (1 - 2 θ₂)^4 θ₂^8 κ - 8 p^2 (1 - 2 θ₂)^3 θ₂^6 κ Sqrt[(1 + θ₂ - θ₂^2)]^2 + 96 p^4 (1 - 2 θ₂)^2 θ₂^6 κ Sqrt[(1 + θ₂ - θ₂^2)]^6 - 10 p^2 (1 - 2 θ₂)^2 θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ - 16 p^2 (1 + θ₂)^3 (1 - 2 θ₂)^3 Sqrt[(1 + θ₂ - θ₂^2)]^2 θ₂ κ + 64 p^2 (1 + θ₂)^2 (1 - 2 θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂ κ + 40 p^2 (1 + θ₂)^2 (1 - 2 θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂ κ - 384 p^4 (1 + θ₂)^2 (1 - 2 θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^8 κ θ₂ + 96 p^2 (1 + θ₂) θ₂^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 κ - 32 p^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂ κ - 24 p^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂ (1 - 2 θ₂) κ + 448 p^4 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^10 κ θ₂ - 32 p^2 (1 - 2 θ₂) (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 κ - 10 p^2 (1 - 2 θ₂)^2 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ + 8 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^3 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ + 16 p^2 (1 - 2 θ₂)^2 (1 + θ₂)^3 κ Sqrt[(1 + θ₂ - θ₂^2)]^4 - 2 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^4 κ - 96 p^4 (1 - 2 θ₂)^2 (1 + θ₂)^3 κ Sqrt[(1 + θ₂ - θ₂^2)]^6 + 4 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 (1 + θ₂) (1 - 2 θ₂) κ + 8 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 (1 + θ₂) κ - 112 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^10 κ (1 + θ₂) - 8 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^2 κ - 4 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^2 (1 - 2 θ₂) κ + 112 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^10 θ₂^2 κ - 48 p^2 (1 - 2 θ₂)^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂ κ + 40 p^2 (1 - 2 θ₂)^3 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^2 κ + 12 p^2 (1 - 2 θ₂)^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 κ - 20 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ + 112 p^2 (1 - 2 θ₂)^2 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^2 κ + 32 p^2 (1 - 2 θ₂) (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^8 κ - 32 p^2 (1 - 2 θ₂)^2 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 κ + 40 p^2 (1 - 2 θ₂)^3 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂ κ - 21 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^2 θ₂^2 κ + 7 p^2 (1 - 2 θ₂)^4 (1 + θ₂)^3 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 80 p^2 (1 - 2 θ₂)^3 (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^3 κ + 21 p^2 (1 - 2 θ₂)^4 (1 + θ₂) θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 32 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^2 (1 - 2 θ₂) κ + 48 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^3 (1 - 2 θ₂)^2 κ - 16 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^10 θ₂^2 κ + 64 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 θ₂^3 (1 - 2 θ₂) κ - 80 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 θ₂^4 (1 - 2 θ₂)^2 κ + 40 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^4 θ₂^5 (1 - 2 θ₂)^3 κ - 20 p^2 (1 - 2 θ₂)^3 θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^4 κ - 12 p^2 (1 - 2 θ₂)^2 θ₂^2 Sqrt[(1 + θ₂ - θ₂^2)]^6 κ - 7 p^2 (1 - 2 θ₂)^4 θ₂^6 Sqrt[(1 + θ₂ - θ₂^2)]^2 κ - 64 p^4 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^10 κ - 32 p^2 (1 + θ₂)^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 κ + 16 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^10 (1 + θ₂) κ - 64 p^2 Sqrt[(1 + θ₂ - θ₂^2)]^8 (1 - 2 θ₂) θ₂ (1 + θ₂) κ + 576 p^4 θ₂ Sqrt[(1 + θ₂ - θ₂^2)]^12 κ - 144 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^12 κ - 224 p^4 (1 - 2 θ₂)^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^10 (1 + θ₂) - 384 p^4 κ (1 - 2 θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^12 θ₂ + 224 p^4 (1 - 2 θ₂)^2 θ₂^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^10 + 192 p^4 (1 - 2 θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^12 κ + 128 p^4 Sqrt[(1 + θ₂ - θ₂^2)]^14 κ - 320 p^4 θ₂^2 Sqrt[(1 + θ₂ - θ₂^2)]^10 κ (1 + θ₂) + 128 p^4 (1 - 2 θ₂) (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^10 κ - 128 p^4 θ₂^2 (1 - 2 θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^10 + 192 p^4 (1 + θ₂)^2 (1 - 2 θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^8 - 384 p^4 θ₂^2 (1 - 2 θ₂) (1 + θ₂) κ Sqrt[(1 + θ₂ - θ₂^2)]^8 + 192 p^4 θ₂^4 Sqrt[(1 + θ₂ - θ₂^2)]^8 κ (1 - 2 θ₂) - 256 p^4 θ₂ Sqrt[(1 + θ₂ - θ₂^2)]^10 κ (1 - 2 θ₂) (1 + θ₂) + 256 p^4 θ₂^3 Sqrt[(1 + θ₂ - θ₂^2)]^10 κ (1 - 2 θ₂) + 128 p^4 θ₂^2 (1 - 2 θ₂)^2 κ (1 + θ₂) Sqrt[(1 + θ₂ - θ₂^2)]^8 - 64 p^4 θ₂^4 (1 - 2 θ₂)^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^8 - 64 p^4 (1 - 2 θ₂)^2 (1 + θ₂)^2 κ Sqrt[(1 + θ₂ - θ₂^2)]^8)/(16 Sqrt[(1 + θ₂ - θ₂^2)]^16) +-- The above result is simplified using the Wolfam language as follows: +-- (p^2 (-25 - 640 p^2 (1 + θ₂- θ₂^2)^2 + 3072 p^4 (1 + θ₂ - θ₂^2)^4) κ) / (16 (1 + θ₂ - θ₂^2)^4) diff --git a/sample/math/number/17th-root-of-unity.egi b/sample/math/number/17th-root-of-unity.egi --- a/sample/math/number/17th-root-of-unity.egi +++ b/sample/math/number/17th-root-of-unity.egi @@ -1,56 +1,56 @@ -z := rtu 17 +def z := rtu 17 -a1 := z ^ 1 + z ^ 16 -a2 := z ^ 2 + z ^ 15 -a3 := z ^ 3 + z ^ 14 -a4 := z ^ 4 + z ^ 13 -a5 := z ^ 5 + z ^ 12 -a6 := z ^ 6 + z ^ 11 -a7 := z ^ 7 + z ^ 10 -a8 := z ^ 8 + z ^ 9 +def a1 := z ^ 1 + z ^ 16 +def a2 := z ^ 2 + z ^ 15 +def a3 := z ^ 3 + z ^ 14 +def a4 := z ^ 4 + z ^ 13 +def a5 := z ^ 5 + z ^ 12 +def a6 := z ^ 6 + z ^ 11 +def a7 := z ^ 7 + z ^ 10 +def a8 := z ^ 8 + z ^ 9 -b11 := a1 + a4 -b12 := a1 - a4 +def b11 := a1 + a4 +def b12 := a1 - a4 -b21 := a2 + a8 -b22 := a2 - a8 +def b21 := a2 + a8 +def b22 := a2 - a8 -b31 := a3 + a5 -b32 := a3 - a5 +def b31 := a3 + a5 +def b32 := a3 - a5 -b41 := a6 + a7 -b42 := a6 - a7 +def b41 := a6 + a7 +def b42 := a6 - a7 -c11 := b11 + b21 -c12 := b11 - b21 +def c11 := b11 + b21 +def c12 := b11 - b21 -c21 := b31 + b41 -c22 := b31 - b41 +def c21 := b31 + b41 +def c22 := b31 - b41 -d10 := c11 + c21 -d11 := c11 - c21 -d12 := c21 - c11 +def d10 := c11 + c21 +def d11 := c11 - c21 +def d12 := c21 - c11 -d10' := -1 +def d10' := -1 -d11' := sqrt 17 +def d11' := sqrt 17 -c11' := (d10' + d11') / 2 -c21' := (d10' - d11') / 2 -c12' := sqrt (8 + (- c11')) -c22' := sqrt (8 + (- c21')) +def c11' := (d10' + d11') / 2 +def c21' := (d10' - d11') / 2 +def c12' := sqrt (8 + (- c11')) +def c22' := sqrt (8 + (- c21')) -b11' := (c11' + c12') / 2 -b21' := (c11' - c12') / 2 -b31' := (c21' + c22') / 2 -b41' := (c21' - c22') / 2 +def b11' := (c11' + c12') / 2 +def b21' := (c11' - c12') / 2 +def b31' := (c21' + c22') / 2 +def b41' := (c21' - c22') / 2 -b12' := sqrt (4 + b21' + (-2) * b31') -b22' := sqrt (4 + b21' + (-2) * b41') -b32' := sqrt (4 + b41' + (-2) * b21') -b42' := sqrt (4 + b31' + (-2) * b21') +def b12' := sqrt (4 + b21' + (-2) * b31') +def b22' := sqrt (4 + b21' + (-2) * b41') +def b32' := sqrt (4 + b41' + (-2) * b21') +def b42' := sqrt (4 + b31' + (-2) * b21') -a1' := (b11' + b12') / 2 +def a1' := (b11' + b12') / 2 assertEqual "17th-root-of-unity" 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 @@ -1,8 +1,8 @@ -m := 3 +def m := 3 -A := +def A := generateTensor - (\match as (integer, integer) with + (\x y -> match (x, y) as (integer, integer) with | (#1, _) -> 1 | ($x, #(x - 1)) -> 1 | (_, _) -> 0) @@ -11,11 +11,9 @@ A -- [| [| 1, 1, 1 |], [| 1, 0, 0 |], [| 0, 1, 0 |] |] -B := +def B := generateTensor - (\match as integer with - | #1 -> 1 - | _ -> 0) + (\x -> if x = 1 then 1 else 0) [m] B diff --git a/sample/n-queens.egi b/sample/n-queens.egi --- a/sample/n-queens.egi +++ b/sample/n-queens.egi @@ -1,29 +1,30 @@ -fourQueens := matchAll [1,2,3,4] as multiset integer with -| $a_1 :: - (!#(a_1 - 1) & !#(a_1 + 1) & $a_2) :: - (!#(a_1 - 2) & !#(a_1 + 2) & !#(a_2 - 1) & !#(a_2 + 1) & $a_3) :: - (!#(a_1 - 3) & !#(a_1 + 3) & !#(a_2 - 2) & !#(a_2 + 2) & !#(a_3 - 1) & !#(a_3 + 1) & $a_4) :: - [] - -> [a_1,a_2,a_3,a_4] +def fourQueens := matchAll [1,2,3,4] as multiset integer with + | $a_1 :: + (!#(a_1 - 1) & !#(a_1 + 1) & $a_2) :: + (!#(a_1 - 2) & !#(a_1 + 2) & !#(a_2 - 1) & !#(a_2 + 1) & $a_3) :: + (!#(a_1 - 3) & !#(a_1 + 3) & !#(a_2 - 2) & !#(a_2 + 2) & !#(a_3 - 1) & !#(a_3 + 1) & $a_4) :: + [] + -> [a_1,a_2,a_3,a_4] fourQueens -- [[2,4,1,3],[3,1,4,2]] -nQueens n := matchAll [1..n] as multiset integer with -| $a_1 :: - (loop $i (2, n) - ((loop $j (1, i - 1) - (!#(a_j - (i - j)) & !#(a_j + (i - j)) & ...) - $a_i) :: ...) - []) --> map (\i -> a_i) [1..n] +def nQueens n := matchAll [1..n] as multiset integer with + | $a_1 :: + (loop $i (2, n) + ((loop $j (1, i - 1) + (!#(a_j - (i - j)) & !#(a_j + (i - j)) & ...) + $a_i) :: ...) + []) + -> map (\i -> a_i) [1..n] nQueens 4 -- [[2,4,1,3],[3,1,4,2]] -fourQueens2 := matchAll [1,2,3,4] as multiset integer with -| $a_1 :: - (!#(a_1 - 1) & !#(a_1 + 1) & $a_2) :: - (!#(a_1 - 2) & !#(a_1 + 2) & !#(a_2 - 1) & !#(a_2 + 1) & $a_3) :: - (!#(a_1 - 3) & !#(a_1 + 3) & !#(a_2 - 2) & !#(a_2 + 2) & !#(a_3 - 1) & !#(a_3 + 1) & $a_4) :: - [] - -> a +def fourQueens2 := matchAll [1,2,3,4] as multiset integer with + | $a_1 :: + (!#(a_1 - 1) & !#(a_1 + 1) & $a_2) :: + (!#(a_1 - 2) & !#(a_1 + 2) & !#(a_2 - 1) & !#(a_2 + 1) & $a_3) :: + (!#(a_1 - 3) & !#(a_1 + 3) & !#(a_2 - 2) & !#(a_2 + 2) & !#(a_3 - 1) & !#(a_3 + 1) & $a_4) :: + [] + -> a + fourQueens2 diff --git a/sample/poker-hands-with-joker.egi b/sample/poker-hands-with-joker.egi --- a/sample/poker-hands-with-joker.egi +++ b/sample/poker-hands-with-joker.egi @@ -1,10 +1,10 @@ -suit := algebraicDataMatcher +def suit := algebraicDataMatcher | spade | heart | club | diamond -card := matcher +def card := matcher | card $ $ as (suit, mod 13) with | Card $x $y -> [(x, y)] | Joker -> matchAll ([Spade, Heart, Club, Diamnond], [1..13]) as (set something, set something) with @@ -12,7 +12,7 @@ | $ as something with | $tgt -> [tgt] -poker cs := +def poker cs := match cs as multiset card with | card $s $n :: card #s #(n-1) :: card #s #(n-2) :: card #s #(n-3) :: card #s #(n-4) :: _ -> "Straight flush" diff --git a/sample/poker-hands.egi b/sample/poker-hands.egi --- a/sample/poker-hands.egi +++ b/sample/poker-hands.egi @@ -1,13 +1,13 @@ -suit := algebraicDataMatcher +def suit := algebraicDataMatcher | spade | heart | club | diamond -card := algebraicDataMatcher +def card := algebraicDataMatcher | card suit (mod 13) -poker cs := +def poker cs := match cs as multiset card with | [card $s $n, card #s #(n-1), card #s #(n-2), card #s #(n-3), card #s #(n-4)] -> "Straight flush" diff --git a/sample/primes.egi b/sample/primes.egi --- a/sample/primes.egi +++ b/sample/primes.egi @@ -5,7 +5,7 @@ -- -- Extract all twin primes from the infinite list of prime numbers with pattern-matching! -twinPrimes := +def twinPrimes := matchAll primes as list integer with | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2) @@ -24,7 +24,7 @@ , (107, 109) ] -- Extract all prime-triplets from the infinite list of prime numbers with pattern-matching! -primeTriplets := +def primeTriplets := matchAll primes as list integer with | _ ++ $p :: ($m & (#(p + 2) | #(p + 4))) :: #(p + 6) :: _ -> (p, m, p + 6) diff --git a/sample/sat/cdcl.egi b/sample/sat/cdcl.egi --- a/sample/sat/cdcl.egi +++ b/sample/sat/cdcl.egi @@ -1,10 +1,10 @@ -literal := integer +def literal := integer -stage := integer +def stage := integer -taggedLiteral := (literal, stage) +def taggedLiteral := (literal, stage) -assignment := +def assignment := matcher | deduced $ $ as (taggedLiteral, multiset taggedLiteral) with | Deduced $e $es -> [(e, es)] @@ -21,55 +21,55 @@ -- Data structure for CNF -toCnf cs := map (\c -> (c, c)) cs +def toCnf cs := map (\c -> (c, c)) cs -fromCnf cs := map 2#%1 cs +def fromCnf cs := map fst cs -- VSIDS -initVars vs := map (\v -> (neg v, 0)) vs ++ map (\v -> (v, 0)) vs +def initVars vs := map (\v -> (neg v, 0)) vs ++ map (\v -> (v, 0)) vs -addVars vs vars := +def addVars vs vars := matchDFS (vs, vars) as (list literal, list (literal, integer)) with - | ([], _) -> sort/fn (\xc yc -> compare (2#%2 yc) (2#%2 xc)) vars + | ([], _) -> sort/fn (\xc yc -> compare (snd yc) (snd xc)) vars | ($v :: $vs', $hs ++ (#v, $c) :: $ts) -> addVars vs' (hs ++ (v, c + 1) :: ts) -deleteVar v vars := +def deleteVar v vars := matchDFS vars as multiset (literal, integer) with | (#v, _) :: (#(neg v), _) :: $vars' -> vars2 | _ -> "error: not matched in delete-var" -- Utility functions for literlas and cnfs -getStage l trail := +def getStage l trail := matchDFS trail as list assignment with | _ ++ whichever (#(neg l), $s) :: _ -> s | _ -> "error: not matched in get-stage" -deleteLiteral l cnf := +def deleteLiteral l cnf := map (\c -> - ( matchAllDFS 2#%1 c as multiset literal with + ( matchAllDFS fst c as multiset literal with | (!#l & $m) :: _ -> m - , 2#%2 c )) + , snd c )) cnf -deleteClausesWith l cnf := +def deleteClausesWith l cnf := matchAllDFS cnf as multiset (multiset literal, multiset literal) with | ((!(#l :: _), _) & $c) :: _ -> c -assignTrue l cnf := deleteLiteral (neg l) (deleteClausesWith l cnf) +def assignTrue l cnf := deleteLiteral (neg l) (deleteClausesWith l cnf) -unitPropagate stage cnf trail := unitPropagate' stage cnf trail trail +def unitPropagate stage cnf trail := unitPropagate' stage cnf trail trail -unitPropagate' stage cnf trail otrail := +def unitPropagate' stage cnf trail otrail := matchDFS trail as list assignment with | whichever ($l, _) :: $trail' -> unitPropagate' stage (assignTrue l cnf) trail' otrail | [] -> unitPropagate'' stage (assignTrue l cnf) otrail -unitPropagate'' stage cnf trail := +def unitPropagate'' stage cnf trail := matchDFS cnf as multiset (multiset literal, multiset literal) with -- empty literal | ([], _) :: _ -> (cnf, trail) @@ -82,27 +82,27 @@ -- otherwise | _ -> (cnf, trail) -learn stage cl trail := +def learn stage cl trail := matchDFS (trail, cl) as (list assignment, multiset taggedLiteral) with -- not more than 2 literals from the current stage | (_, !((_, #stage) :: (_, #stage) :: _)) -> - (minimum (map 2#%2 cl), map 2#%1 cl) + (minimum (map snd cl), map fst cl) -- otherwise | (_ ++ deduced ($l, #stage) $ds :: $trail', (#(neg l), #stage) :: $rs) -> learn stage (union rs ds) trail' -backjump stage trail := +def backjump stage trail := matchDFS trail as list assignment with | _ ++ (guessed (_, #stage) :: _ & $trail') -> trail' | _ -> trail -guess vars trail := +def guess vars trail := matchDFS (vars, trail) as (list (literal, integer), list assignment) with | (_ ++ ($l, _) :: _, !(_ ++ whichever (#l | #(neg l), _) :: _)) -> neg l -cdcl vars cnf := cdcl' 0 0 (initVars vars) (toCnf cnf) [] +def cdcl vars cnf := cdcl' 0 0 (initVars vars) (toCnf cnf) [] -cdcl' count stage vars cnf trail := +def cdcl' count stage vars cnf trail := let (cnf', trail') := unitPropagate stage cnf trail in matchDFS cnf' as multiset (multiset literal, multiset literal) with | [] -> True @@ -130,7 +130,7 @@ cnf (Guessed (g, stage + 1) :: trail') -problem20 := +def problem20 := [[4, -18, 19], [3, 18, -5], [-5, -8, -15], [-20, 7, -16], [10, -13, -7], [-12, -9, 17], [17, 19, 5], [-16, 9, 15], [11, -5, -14], [18, -10, 13], [-3, 11, 12], [-6, -17, -8], [-18, 14, 1], [-19, -15, 10], [12, 18, -19], @@ -151,7 +151,7 @@ [-5, -17, -19], [-20, -18, 11], [-9, 1, -5], [-19, 9, 17], [12, -2, 17], [4, -16, -5]] -problem50 := +def problem50 := [[18, -8, 29], [-16, 3, 18], [-36, -11, -30], [-50, 20, 32], [-6, 9, 35], [42, -38, 29], [43, -15, 10], [-48, -47, 1], [-45, -16, 33], [38, 42, 22], [-49, 41, -34], [12, 17, 35], [22, -49, 7], [-10, -11, -39], [-28, -36, -37], diff --git a/sample/sat/dp.egi b/sample/sat/dp.egi --- a/sample/sat/dp.egi +++ b/sample/sat/dp.egi @@ -2,25 +2,25 @@ -- This file has been auto-generated by egison-translator. -- -deleteLiteral l cnf := +def deleteLiteral l cnf := map (\c -> matchAll c as multiset integer with | ((!#l) & $x) :: _ -> x) cnf -deleteClausesWith l cnf := +def deleteClausesWith l cnf := matchAll cnf as multiset (multiset integer) with | ((!(#l :: _)) & $c) :: _ -> c -assignTrue l cnf := deleteLiteral (neg l) (deleteClausesWith l cnf) +def assignTrue l cnf := deleteLiteral (neg l) (deleteClausesWith l cnf) -resolveOn v cnf := +def resolveOn v cnf := matchAll cnf as multiset (multiset integer) with | {(#v :: (@ & $xs)) :: (#(neg v) :: (@ & $ys)) :: _, !( $l :: _, #(neg l) :: _ )} -> unique (xs ++ ys) -dp vars cnf := +def dp vars cnf := match (vars, cnf) as (multiset integer, multiset (multiset integer)) with | (_, []) -> True | (_, [] :: _) -> False diff --git a/sample/tree.egi b/sample/tree.egi --- a/sample/tree.egi +++ b/sample/tree.egi @@ -1,4 +1,4 @@ -tree a := matcher +def tree a := matcher | leaf $ as a with | Leaf $x -> [x] | Node _ _ -> [] @@ -15,7 +15,7 @@ | $ as something with | $tgt -> [tgt] -treeData := +def treeData := Node "Programming language" [Node "pattern-match-oriented" [Leaf "Egison"], Node "Functional language" @@ -24,7 +24,7 @@ Node "Logic programming" [Leaf "Prolog", Leaf "Curry"], Node "Object oriented" [Leaf "C++", Leaf "Java", Leaf "Ruby", Leaf "Python", Leaf "OCaml"]] -ancestors x t := +def ancestors x t := matchAllDFS t as tree eq with | $hs ++ leaf #x -> hs @@ -32,7 +32,7 @@ (ancestors "Egison" treeData) [["Programming language", "pattern-match-oriented"], ["Programming language", "Functional language", "Dynamically typed"]] -descendants x t := +def descendants x t := matchAllDFS t as tree eq with | _ ++ #x :: _ ++ leaf $y -> y diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,29 +1,20 @@ module Main where -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class -import Data.IORef -import Data.List +import Control.Monad.Trans.Class (lift) -import System.FilePath (replaceDirectory, splitPath, - takeDirectory) -import System.FilePath.Glob (glob) import Test.Framework (defaultMain) import Test.Framework.Providers.HUnit (hUnitTestToTests) import Test.HUnit import Language.Egison -import Language.Egison.Core -import Language.Egison.CmdOptions +import Language.Egison.Eval +import Language.Egison.MathOutput import Language.Egison.Parser -import Language.Egison.Pretty -import Language.Egison.Primitives -import Language.Egison.Types main :: IO () -main = - defaultMain . hUnitTestToTests . test $ map runTestCase testCases +main = do + t <- evalRuntimeT defaultOption mathOutputTest + defaultMain . hUnitTestToTests . test $ t : map runTestCase testCases testCases :: [FilePath] testCases = @@ -55,20 +46,32 @@ ] runTestCase :: FilePath -> Test -runTestCase file = TestLabel file . TestCase $ do - env <- initialEnv defaultOption - assertEvalM $ do - exprs <- loadFile file - let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs - env' <- recursiveBind env bindings - forM_ tests $ evalExprDeep env' - where - assertEvalM :: EvalM a -> Assertion - assertEvalM m = fromEvalM m >>= assertString . either show (const "") +runTestCase file = TestLabel file . TestCase . assertEvalM $ do + env <- lift $ lift initialEnv + exprs <- loadFile file + evalTopExprsNoPrint env exprs + where + assertEvalM :: EvalM a -> Assertion + assertEvalM m = fromEvalM defaultOption m >>= assertString . either show (const "") -collectDefsAndTests :: EgisonTopExpr -> ([(Var, EgisonExpr)], [EgisonExpr]) -> ([(Var, EgisonExpr)], [EgisonExpr]) -collectDefsAndTests (Define name expr) (bindings, tests) = - ((name, expr) : bindings, tests) -collectDefsAndTests (Test expr) (bindings, tests) = - (bindings, expr : tests) -collectDefsAndTests _ r = r +mathOutputTest :: RuntimeM Test +mathOutputTest = do + env <- initialEnv + latexTest <- mathOutputTestLatex env + return $ TestList [latexTest] + +mathOutputTestLatex :: Env -> RuntimeM Test +mathOutputTestLatex env = do + TestLabel "math output: latex" . TestList <$> + mapM (\(x, y, z) -> makeTest x y z) + [ ("div", "x / y", "\\frac{x}{y}") + ] + where + makeTest = makeMathOutputTest env "latex" + +makeMathOutputTest :: Env -> String -> String -> String -> String -> RuntimeM Test +makeMathOutputTest env lang label expr expectedOutput = do + res <- fromEvalT (runExpr env expr) + case res of + Left _ -> return . TestCase $ assertFailure "Failed to evaluate the expression" + Right res -> return . TestCase $ assertEqual label ("#" ++ lang ++ "|" ++ expectedOutput ++ "|#") (prettyMath lang res) diff --git a/test/lib/core/collection.egi b/test/lib/core/collection.egi --- a/test/lib/core/collection.egi +++ b/test/lib/core/collection.egi @@ -249,6 +249,18 @@ (splitAs integer [0] [1, 2, 0, 3, 3, 0, 4, 0]) [[1, 2], [3, 3], [4], []] +assertEqual "splitAt" + (splitAt 0 [1, 2, 3]) + ([], [1, 2, 3]) + +assertEqual "splitAt" + (splitAt 2 [1, 2, 3]) + ([1, 2], [3]) + +assertEqual "splitAt" + (splitAt 4 [1, 2, 3]) + ([1, 2, 3], []) + assertEqual "findCycle" (findCycle [1, 3, 4, 5, 2, 7, 5, 2, 7, 5, 2, 7]) ([1, 3, 4], [5, 2, 7]) 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" - (2#(%1, take 10 %2) (rtod (6 / 35))) + ((\(x, y) -> (x, take 10 y)) (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,12 +106,12 @@ assertEqual "regularContinuedFractionOfSqrt case 1" - (2#(%1, take 10 %2) (regularContinuedFractionOfSqrt 2)) + ((\(x, y) -> (x, take 10 y)) (regularContinuedFractionOfSqrt 2)) (1, [2, 2, 2, 2, 2, 2, 2, 2, 2, 2]) assertEqual "regularContinuedFractionOfSqrt case 2" (rtof - (regularContinuedFraction - (2#(%1, take 100 %2) (regularContinuedFractionOfSqrt 2)))) + (let (x, y) := regularContinuedFractionOfSqrt 2 + in regularContinuedFraction x (take 100 y))) 1.4142135623730951 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 @@ -56,22 +56,18 @@ in f A_i) [|[|1, 1|], [|1, 1|]|]_i_j -g_i_j := (generateTensor - (\match as (integer, integer) with - | ($n, #n) -> function (x, y, z) - | (_, _) -> 0) - [3, 3])_i_j - assertEqual "generate_tensor by using function expr" - (show (withSymbols [i, j] d/d g_i_j x)) + (let g_i_j := (generateTensor + (\n m -> if n = m then function (x, y, z) else 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 |] |]" -h_i_j := [|[|function (x, y, z), 0, 0|] - , [|0, function (x, y, z), 0|] - , [|0, 0, function (x, y, z)|]|]_i_j - assertEqual "define tensor having value of function expr" - (show (withSymbols [i, j] d/d h_i_j x)) + (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 |] |]" diff --git a/test/primitive.egi b/test/primitive.egi --- a/test/primitive.egi +++ b/test/primitive.egi @@ -6,7 +6,7 @@ assertEqual "quotient" (quotient (-21) 13) (-1) -assertEqual "remainder" (remainder (-21) 13) (-8) +assertEqual "remainder" ((-21) % 13) (-8) assertEqual "neg" (neg (-89)) 89 @@ -113,10 +113,8 @@ assertEqual "regexCg" (regexCg "([0-9]+),([0-9]+)" "abc,123,45,defg") [("abc,", ["123", "45"], ",defg")] --- addPrime -- addSubscript -- addSuperscript --- readProcess assertEqual "read" (read "3") 3 assertEqual "read" (read "3.14") 3.14 diff --git a/test/syntax.egi b/test/syntax.egi --- a/test/syntax.egi +++ b/test/syntax.egi @@ -66,10 +66,10 @@ (let { x := 1; y := x + 1 } in y) 2 -io do print "io and do expression" - return 0 +io $ do print "io and do expression" + return 0 -io do { print "io and do expression without newline"; return 0 } +io $ do { print "io and do expression without newline"; return 0 } assertEqual "where" (f 0 + y + 1 @@ -107,14 +107,18 @@ ((\x y -> x + y) 1 2 + 3) 6 -assertEqual "lambda with 0 argument" +assertEqual "lambda with case" ((\() -> 1) ()) 1 -assertEqual "lambda with tuple argument" - ((\(x, y, z) -> x + y + z) 1 2 3) - 6 +assertEqual "lambda with case" + ((\(x, y, z) -> x - y - z) (1, 2, 3)) + (-4) +assertEqual "lambda with case" + ((\_ -> 1) 2) + 1 + assertEqual "append op" ([1] ++ [2]) [1, 2] assertEqual "append op" ((++) [1] [2]) [1, 2] @@ -133,20 +137,20 @@ -- user-defined infix infixl expression 5 @ -(@) x y := x - y +def (@) x y := x - y assertEqual "user defined infix" (4 @ 3 @ 5) (-4) infixl expression 5 @@ -(@@) %x y := x - y +def (@@) %x y := x - y assertEqual "user defined infix with tensor arg" (4 @@ 3 @@ 2) (-1) -findFactor := +def findFactor := memoizedLambda n -> match takeWhile (<= floor (sqrt (itof n))) primes as list integer with | _ ++ (?(\m -> divisor n m) & $x) :: _ -> x @@ -156,7 +160,7 @@ (map findFactor [1..10]) [1, 2, 3, 2, 5, 2, 7, 2, 3, 2] -twinPrimes := +def twinPrimes := matchAll primes as list integer with | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2) @@ -164,7 +168,7 @@ (take 10 twinPrimes) [(3, 5), (5, 7), (11, 13), (17, 19), (29, 31), (41, 43), (59, 61), (71, 73), (101, 103), (107, 109)] -primeTriplets := +def primeTriplets := matchAll primes as list integer with | _ ++ $p :: ((#(p + 2) | #(p + 4)) & $m) :: #(p + 6) :: _ -> (p, m, p + 6) @@ -173,21 +177,21 @@ (take 10 primeTriplets) [(5, 7, 11), (7, 11, 13), (11, 13, 17), (13, 17, 19), (17, 19, 23), (37, 41, 43), (41, 43, 47), (67, 71, 73), (97, 101, 103), (101, 103, 107)] -someFunction x y z := +def someFunction x y z := x + y * z assertEqual "function definition" (someFunction 1 2 3) 7 -someFunctionWithDollar $x $y $z := +def someFunctionWithDollar $x $y $z := x + y + z assertEqual "function definition with '$' scalar arg" (someFunctionWithDollar 1 2 3) 6 -gcd m n := +def gcd m n := if m >= n then if n = 0 then m else gcd n (m % n) @@ -197,7 +201,7 @@ (gcd 143 22) 11 -A x := 1 +def A x := 1 assertEqual "definition of upper-case identifier" (A 2) @@ -207,15 +211,15 @@ (capply (+) [1, 2]) 3 -f0 () := 1 -f2 (x, y) := x + y +def f0 () := 1 +def f2 (x, y) := x + y assertEqual "nullary function definition" (f0 ()) 1 assertEqual "function definition with tupled argument" - (f2 1 2) + (f2 (1, 2)) 3 {- @@ -437,11 +441,11 @@ | $x :: $y :: _ -> (x, y)) [(1, 2), (1, 3), (2, 1), (2, 3), (3, 1), (3, 2)] -tree a := algebraicDataMatcher +def tree a := algebraicDataMatcher | leaf | node (tree a) a (tree a) -treeInsert n t := +def treeInsert n t := match t as tree integer with | leaf -> Node Leaf n Leaf | node $t1 $m $t2 -> match (compare n m) as ordering with @@ -449,7 +453,7 @@ | equal -> Node t1 n t2 | greater -> Node t1 m (treeInsert n t2) -treeMember n t := +def treeMember n t := match t as tree integer with | leaf -> False | node $t1 $m $t2 -> match (compare n m) as ordering with @@ -535,13 +539,37 @@ in x_(i_1)..._(i_3)) 6 -TestT := generateTensor 3#x_%1_%2_%3 [2,3,4] -TestC_c_a_b := TestT_a_b_c +def TestT := generateTensor 3#x_%1_%2_%3 [2,3,4] +def TestC_c_a_b := TestT_a_b_c assertEqual "transpose" TestC_#_#_# - (tensor [4, 2, 3] [x_1_1_1, x_1_2_1, x_1_3_1, x_2_1_1, x_2_2_1, x_2_3_1, x_1_1_2, x_1_2_2, x_1_3_2, x_2_1_2, x_2_2_2, x_2_3_2, x_1_1_3, x_1_2_3, x_1_3_3, x_2_1_3, x_2_2_3, x_2_3_3, x_1_1_4, x_1_2_4, x_1_3_4, x_2_1_4, x_2_2_4, x_2_3_4] )_#_#_# + (tensor [4, 2, 3] + [x_1_1_1, x_1_2_1, x_1_3_1, x_2_1_1, x_2_2_1, x_2_3_1, + x_1_1_2, x_1_2_2, x_1_3_2, x_2_1_2, x_2_2_2, x_2_3_2, + x_1_1_3, x_1_2_3, x_1_3_3, x_2_1_3, x_2_2_3, x_2_3_3, + x_1_1_4, x_1_2_4, x_1_3_4, x_2_1_4, x_2_2_4, x_2_3_4])_#_#_# +def symmT{_i_j} := + [| [| 0, 1, 2 |], + [| 1, 0, 3 |], + [| 2, 3, 0 |] |] + +def asymmT[_i_j] := + [| [| 0, 1, 2 |], + [| -1, 0, 3 |], + [| -2, -3, 0 |] |] + +assert "symmetric tensor" + (symmT_1_1 = 0 && symmT_1_2 = 1 && symmT_1_3 = 2 && + symmT_2_1 = 1 && symmT_2_2 = 0 && symmT_2_3 = 3 && + symmT_3_1 = 2 && symmT_3_2 = 3 && symmT_3_3 = 0) + +assert "symmetric tensor" + (asymmT_1_1 = 0 && asymmT_1_2 = 1 && asymmT_1_3 = 2 && + asymmT_2_1 = -1 && asymmT_2_2 = 0 && asymmT_2_3 = 3 && + asymmT_3_1 = -2 && asymmT_3_2 = -3 && asymmT_3_3 = 0) + -- -- Hash -- @@ -558,10 +586,14 @@ {| (1, 11), (2, 12), (3, 13), (4, 14), (5, 15), |}_3 13 --- assertEqual "string hash access" --- {| ("1", 11), ("2", 12), ("3", 13), ("4", 14), ("5", 15) |}_"3" --- 13 +assertEqual "string hash access" + {| ("1", 11), ("2", 12), ("3", 13), ("4", 14), ("5", 15) |}_"3" + 13 +assertEqual "char hash access" + {| ('a', 11), ('b', 12), ('c', 13), ('d', 14), ('e', 15) |}_'c' + 13 + -- -- Partial Application -- @@ -574,13 +606,13 @@ (take 10 (1#(%1 :: (%0 (%1 * 2))) 2)) [2, 4, 8, 16, 32, 64, 128, 256, 512, 1024] -f *x *y := x + y +def f *$x *$y := x + y assertEqual "double inverted index" (f [|1, 2, 3|]_i [|10, 20, 30|]_j) [| [| 11, 21, 31, |], [| 12, 22, 32, |], [| 13, 23, 33, |], |]~i~j -g $x *y := x + y +def g $x *$y := x + y assertEqual "single inverted index" (g [|1, 2, 3|]_i [|10, 20, 30|]_j) @@ -590,7 +622,7 @@ -- matcherExpr -- -list a := matcher +def list a := matcher | [] as () with | [] -> [()] | _ -> [] @@ -616,7 +648,7 @@ | $ as something with | $tgt -> [tgt] -multiset a := matcher +def multiset a := matcher | [] as () with | $tgt -> match tgt as (mutiset a) with | [] -> [()] @@ -637,7 +669,7 @@ | $x :: _ -> x) [1, 2, 3] -nishiwakiIf b e1 e2 := +def nishiwakiIf b e1 e2 := head (matchAll b as (matcher | $ as something with | True -> [e1] @@ -653,7 +685,7 @@ infixl pattern 7 <> infixl pattern 4 -- '?' is allowed from the 2nd character -dummyMatcher := matcher +def dummyMatcher := matcher | $ <> $ as (integer, integer) with | $x :: $y :: [] -> [(x, y)] | _ -> [] @@ -668,3 +700,20 @@ assertEqual "user-defined pattern infix" (match [1, 2] as dummyMatcher with $x $y :: _ -> x + y) 3 + +-- Primitive data pattern match with let expression +assertEqual "let pattern match" + (let (x :: xs) := [1, 2, 3] in (x, xs)) + (1, [2, 3]) + +assertEqual "let pattern match" + (let (snoc xs x) := [1, 2, 3] in (x, xs)) + (3, [1, 2]) + +assertEqual "let pattern match" + (let (Just x) := Just 1 in x) + 1 + +assertEqual "let pattern match" + (let (x, y) := (2, 3) in x + y) + 5