packages feed

egison 4.0.3 → 4.1.0

raw patch · 105 files changed

+6541/−5810 lines, 105 filesdep +exceptionsdep +sweet-egisondep +unicode-showdep −deepseqdep −mini-egisondep ~mtl

Dependencies added: exceptions, sweet-egison, unicode-show

Dependencies removed: deepseq, mini-egison

Dependency ranges changed: mtl

Files

benchmark/Benchmark.hs view
@@ -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"
egison.cabal view
@@ -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
hs-src/Interpreter/egison.hs view
@@ -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
hs-src/Language/Egison.hs view
@@ -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"   ]
hs-src/Language/Egison/AST.hs view
@@ -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
hs-src/Language/Egison/CmdOptions.hs view
@@ -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])
hs-src/Language/Egison/Completion.hs view
@@ -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
hs-src/Language/Egison/Core.hs view
@@ -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 "<stdin>"-  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 "<stdin>"-  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
hs-src/Language/Egison/Data.hs view
@@ -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{} = "#<user-matcher>"-  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 _) = "#<lambda [" ++ intercalate ", " (map show args) ++ "] ...>"+  show (CFunc _ name _) = "#<cambda " ++ name ++ " ...>"+  show (MemoizedFunc _ _ names _) = "#<memoized-lambda [" ++ intercalate ", " names ++ "] ...>"   show PatternFunc{} = "#<pattern-function>"-  show (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"-  show (IOFunc _) = "#<io-function>"-  show (Port _) = "#<port>"+  show PrimitiveFunc{} = "#<primitive-function>"+  show LazyPrimitiveFunc{} = "#<primitive-function>"+  show IOFunc{} = "#<io-function>"+  show Port{}   = "#<port>"+  show RefBox{} = "#<refbox>"   show Something = "something"   show Undefined = "undefined"   show World = "#<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 _)   = "#<thunk>"@@ -501,105 +429,38 @@   show _ = "#<ref>"  ----- 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
+ hs-src/Language/Egison/Data/Collection.hs view
@@ -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
+ hs-src/Language/Egison/Data/Utils.hs view
@@ -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
hs-src/Language/Egison/Desugar.hs view
@@ -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
+ hs-src/Language/Egison/Eval.hs view
@@ -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 "<stdin>"+  val <- evalExprDeep env expr+  popFuncName+  return (Just val, env)+evalTopExpr' env (IExecute expr) = do+  pushFuncName "<stdin>"+  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')
+ hs-src/Language/Egison/EvalState.hs view
@@ -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
+ hs-src/Language/Egison/IExpr.hs view
@@ -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 _ _)   = ""
− hs-src/Language/Egison/IState.hs 
@@ -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
+ hs-src/Language/Egison/Match.hs view
@@ -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
+ hs-src/Language/Egison/Math.hs view
@@ -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
+ hs-src/Language/Egison/Math/Arith.hs view
@@ -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 []])
+ hs-src/Language/Egison/Math/Expr.hs view
@@ -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
+ hs-src/Language/Egison/Math/Normalize.hs view
@@ -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 |]+      ]
+ hs-src/Language/Egison/Math/Rewrite.hs view
@@ -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 |]+      ]
− hs-src/Language/Egison/MathExpr.hs 
@@ -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 []])
hs-src/Language/Egison/MathOutput.hs view
@@ -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
hs-src/Language/Egison/Parser.hs view
@@ -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"
hs-src/Language/Egison/Parser/NonS.hs view
@@ -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
hs-src/Language/Egison/Parser/SExpr.hs view
@@ -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 ()))
hs-src/Language/Egison/Pretty.hs view
@@ -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{} = "#<user-matcher>"-  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{} = "#<pattern-function>"-  prettyS (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"-  prettyS (IOFunc _) = "#<io-function>"-  prettyS (Port _) = "#<port>"-  prettyS Something = "something"-  prettyS Undefined = "undefined"-  prettyS World = "#<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
hs-src/Language/Egison/PrettyMath/AST.hs view
@@ -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
hs-src/Language/Egison/PrettyMath/AsciiMath.hs view
@@ -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) ++ ")"
hs-src/Language/Egison/PrettyMath/Latex.hs view
@@ -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
hs-src/Language/Egison/PrettyMath/Mathematica.hs view
@@ -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
hs-src/Language/Egison/PrettyMath/Maxima.hs view
@@ -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
hs-src/Language/Egison/Primitives.hs view
@@ -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
+ hs-src/Language/Egison/Primitives/Arith.hs view
@@ -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
+ hs-src/Language/Egison/Primitives/IO.hs view
@@ -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
+ hs-src/Language/Egison/Primitives/String.hs view
@@ -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
+ hs-src/Language/Egison/Primitives/Types.hs view
@@ -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
+ hs-src/Language/Egison/Primitives/Utils.hs view
@@ -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')
+ hs-src/Language/Egison/RState.hs view
@@ -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
hs-src/Language/Egison/Tensor.hs view
@@ -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'
− hs-src/Language/Egison/Types.hs 
@@ -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
hs-src/Tool/translator.hs view
@@ -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
lib/core/assoc.egi view
@@ -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)
lib/core/base.egi view
@@ -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)]
lib/core/collection.egi view
@@ -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
lib/core/io.egi view
@@ -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
lib/core/maybe.egi view
@@ -4,7 +4,7 @@ -- -- -maybe a :=+def maybe a :=   matcher     | nothing as () with       | Nothing -> [()]
lib/core/number.egi view
@@ -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
lib/core/order.egi view
@@ -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
lib/core/random.egi view
@@ -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)
lib/core/shell.egi view
@@ -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
+ lib/core/sort.egi view
@@ -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
lib/core/string.egi view
@@ -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
lib/math/algebra/equations.egi view
@@ -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)
lib/math/algebra/inverse.egi view
@@ -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
lib/math/algebra/matrix.egi view
@@ -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]
lib/math/algebra/root.egi view
@@ -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
lib/math/algebra/tensor.egi view
@@ -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))
lib/math/algebra/vector.egi view
@@ -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
lib/math/analysis/derivative.egi view
@@ -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]))
lib/math/analysis/integral.egi view
@@ -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
lib/math/common/arithmetic.egi view
@@ -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
lib/math/common/constants.egi view
@@ -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|]|]
lib/math/common/functions.egi view
@@ -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
lib/math/expression.egi view
@@ -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
lib/math/geometry/3d-euclidean-space.egi view
@@ -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
lib/math/geometry/4d-euclidean-space.egi view
@@ -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
lib/math/geometry/differential-form.egi view
@@ -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)
lib/math/geometry/minkowski-space.egi view
@@ -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
+ lib/math/no-normalize.egi view
@@ -0,0 +1,7 @@+--+--+-- Term Rewriting+--+--++def mathNormalize := id
lib/math/normalize.egi view
@@ -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
+ sample/bellman-ford.egi view
@@ -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 |]|]
sample/chopsticks.egi view
@@ -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)
sample/chopsticks2.egi view
@@ -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)
sample/demo1-ja.egi view
@@ -1,5 +1,5 @@ -- 素数の無限リストから全ての双子素数をパターンマッチにより抽出-twinPrimes :=+def twinPrimes :=   matchAll primes as list integer with     | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2)
sample/demo1.egi view
@@ -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)
sample/generalized-sequential-pattern-mining.egi view
@@ -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 :: _) :: _) :: _),
+ sample/graph.egi view
@@ -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
sample/ioRef.egi view
@@ -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
sample/mahjong.egi view
@@ -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
sample/math/geometry/curvature-form.egi view
@@ -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 |] |]~#_#
sample/math/geometry/hodge-laplacian-polar.egi view
@@ -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 θ |]
sample/math/geometry/riemann-curvature-tensor-of-S2.egi view
@@ -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"
+ sample/math/geometry/riemann-curvature-tensor-of-S5-non-sym.egi view
@@ -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
+ sample/math/geometry/riemann-curvature-tensor-of-S5.egi view
@@ -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
+ sample/math/geometry/riemann-curvature-tensor-of-T2-non-sym.egi view
@@ -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)))
sample/math/geometry/riemann-curvature-tensor-of-T2.egi view
@@ -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"
+ sample/math/geometry/thurston-non-sym.egi view
@@ -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)
+ sample/math/geometry/thurston.egi view
@@ -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)
sample/math/number/17th-root-of-unity.egi view
@@ -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"
sample/math/number/tribonacci.egi view
@@ -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
sample/n-queens.egi view
@@ -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
sample/poker-hands-with-joker.egi view
@@ -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"
sample/poker-hands.egi view
@@ -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"
sample/primes.egi view
@@ -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)
sample/sat/cdcl.egi view
@@ -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],
sample/sat/dp.egi view
@@ -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
sample/tree.egi view
@@ -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
test/Test.hs view
@@ -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)
test/lib/core/collection.egi view
@@ -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])
test/lib/core/number.egi view
@@ -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
test/lib/math/tensor.egi view
@@ -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 |] |]"
test/primitive.egi view
@@ -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
test/syntax.egi view
@@ -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