packages feed

egison 3.10.3 → 4.0.0

raw patch · 204 files changed

+7532/−14748 lines, 204 filesdep +mini-egison

Dependencies added: mini-egison

Files

egison.cabal view
@@ -1,5 +1,5 @@ Name:                egison-Version:             3.10.3+Version:             4.0.0 Synopsis:            Programming language with non-linear pattern-matching against non-free data Description:   An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language.@@ -59,11 +59,10 @@  Extra-Source-Files:  benchmark/Benchmark.hs -Data-files:          lib/core/*.egi lib/math/*.egi lib/math/common/*.egi lib/math/algebra/*.egi lib/math/analysis/*.egi lib/math/geometry/*.egi-                     sample/*.egi sample/sat/*.egi sample/io/*.egi sample/math/algebra/*.egi sample/math/analysis/*.egi sample/math/geometry/*.egi sample/math/number/*.egi sample/math/others/*.egi-                     nons-sample/math/geometry/*.egi+Data-files:          lib/core/shell.egi+                     lib/core/*.egi lib/math/*.egi lib/math/common/*.egi lib/math/algebra/*.egi lib/math/analysis/*.egi lib/math/geometry/*.egi+                     sample/*.egi sample/sat/*.egi sample/math/geometry/*.egi sample/math/number/*.egi                      test/*.egi test/lib/core/*.egi test/lib/math/*.egi-                     nons-test/test/*.egi nons-test/test/lib/core/*.egi nons-test/test/lib/math/*.egi                      elisp/egison-mode.el  @@ -95,6 +94,7 @@     , hashable     , optparse-applicative     , prettyprinter+    , mini-egison >= 1.0.0   if !impl(ghc > 8.0)     Build-Depends: fail   Hs-Source-Dirs:  hs-src@@ -103,17 +103,20 @@                    Language.Egison.AST                    Language.Egison.Core                    Language.Egison.CmdOptions+                   Language.Egison.Completion                    Language.Egison.Desugar                    Language.Egison.Data-                   Language.Egison.Types-                   Language.Egison.Tensor+                   Language.Egison.IState+                   Language.Egison.MathExpr+                   Language.Egison.MathOutput+                   Language.Egison.MList                    Language.Egison.Parser-                   Language.Egison.ParserNonS+                   Language.Egison.Parser.SExpr+                   Language.Egison.Parser.NonS                    Language.Egison.Pretty                    Language.Egison.Primitives-                   Language.Egison.Util-                   Language.Egison.MathExpr-                   Language.Egison.MathOutput+                   Language.Egison.Tensor+                   Language.Egison.Types   Other-modules:   Paths_egison   ghc-options:  -O3 -Wall -Wno-name-shadowing -Wno-incomplete-patterns @@ -164,6 +167,7 @@     , filepath     , text     , process+    , regex-tdfa     , vector     , optparse-applicative   if !impl(ghc > 8.0)
hs-src/Interpreter/egison.hs view
@@ -8,73 +8,93 @@ import           Control.Monad.Except import           Control.Monad.Trans.State +import           Data.List                  (intercalate) import qualified Data.Text                  as T  import           Data.Version  import           System.Console.Haskeline   hiding (catch, handle, throwTo)+import           System.Console.Haskeline.History (addHistoryUnlessConsecutiveDupe) import           System.Directory           (getHomeDirectory) import           System.Exit                (exitFailure, exitSuccess) import           System.FilePath            ((</>)) import           System.IO+import           Text.Regex.TDFA            ((=~))  import           Language.Egison import           Language.Egison.CmdOptions-import           Language.Egison.Core       (recursiveBind)+import           Language.Egison.Completion+import           Language.Egison.Core       (evalTopExpr', recursiveBind)+import           Language.Egison.Desugar import           Language.Egison.MathOutput-import           Language.Egison.Util+import qualified Language.Egison.Parser.SExpr as SExpr+import qualified Language.Egison.Parser.NonS  as NonS  import           Options.Applicative  main :: IO () main = execParser cmdParser >>= runWithOptions +isInValidMathOption :: EgisonOpts -> Bool+isInValidMathOption EgisonOpts{ optMathExpr = Just lang } = notElem lang ["asciimath", "latex", "mathematica", "maxima"]+isInValidMathOption EgisonOpts{ optMathExpr = Nothing } = False+ runWithOptions :: EgisonOpts -> IO ()-runWithOptions opts-  | optShowVersion opts = putStrLn (showVersion version) >> exitSuccess-  | isInValidMathOption opts = hPrint stderr (Default "this output lang is not supported") >> exitFailure-  | otherwise = do-      coreEnv <- initialEnv opts-      mEnv <- evalEgisonTopExprs opts coreEnv $ map Load (optLoadLibs opts) ++ map LoadFile (optLoadFiles opts)-      case mEnv of-        Left err -> print err-        Right env ->-          case opts of-            EgisonOpts { optEvalString = Just expr }-              | optTsvOutput opts ->-                f opts env $ "(execute (each (compose show-tsv print) " ++ expr ++ "))"-              | otherwise -> do-                ret <- runEgisonExpr opts env expr-                case ret of-                  Left err  -> hPrint stderr err >> exitFailure-                  Right val -> print val >> exitSuccess-            EgisonOpts { optExecuteString = Just cmd } ->-              f opts env $ "(execute " ++ cmd ++ ")"-            EgisonOpts { optSubstituteString = Just sub } ->-              let expr = "(load \"lib/core/shell.egi\") "-                      ++ "(execute (each (compose " ++ (if optTsvOutput opts then "show-tsv" else "show") ++ " print) (let {[$SH.input (SH.gen-input {" ++ unwords (map fst $ optFieldInfo opts) ++  "} {" ++ unwords (map snd $ optFieldInfo opts) ++  "})]} (" ++ sub ++ " SH.input))))"-                in f opts env expr-            EgisonOpts { optExecFile = Nothing } ->-              when (optShowBanner opts) showBanner >> repl opts env >> when (optShowBanner opts) showByebyeMessage >> exitSuccess-            EgisonOpts { optExecFile = Just (file, args) }-              | optTestOnly opts -> do-                result <- if optNoIO opts-                            then do input <- readFile file-                                    runEgisonTopExprs opts env input-                            else evalEgisonTopExprs opts env [LoadFile file]-                either print (const $ return ()) result-              | otherwise -> do-                result <- evalEgisonTopExprs opts env [LoadFile file, Execute (ApplyExpr (VarExpr $ stringToVar "main") (CollectionExpr (map ((ElementExpr . StringExpr) . T.pack) args)))]-                either print (const $ return ()) result- where-  isInValidMathOption EgisonOpts{ optMathExpr = Just lang } = notElem lang ["asciimath", "latex", "mathematica", "maxima"]-  isInValidMathOption EgisonOpts{ optMathExpr = Nothing } = False-  f opts env expr = do-    cmdRet <- runEgisonTopExpr opts env expr-    case cmdRet of-      Left err -> hPrint stderr err >> exitFailure-      _        -> exitSuccess+runWithOptions opts | isInValidMathOption opts =+  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)+  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.segi\"\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 +executeEgisonTopExpr :: EgisonOpts -> Env -> String -> IO ()+executeEgisonTopExpr opts env expr = do+  cmdRet <- runEgisonTopExprs opts env expr+  case cmdRet of+    Left err -> hPrint stderr err >> exitFailure+    _        -> exitSuccess+ showBanner :: IO () showBanner = do   putStrLn $ "Egison Version " ++ showVersion version@@ -101,14 +121,14 @@     input <- liftIO $ runInputT (settings home) $ getEgisonExpr opts     case (optNoIO opts, input) of       (_, Nothing) -> return ()-      (True, Just (_, LoadFile _)) -> do+      (True, Just (LoadFile _)) -> do         putStrLn "error: No IO support"         loop st-      (True, Just (_, Load _)) -> do+      (True, Just (Load _)) -> do         putStrLn "error: No IO support"         loop st-      (_, Just (topExpr, _)) -> do-        result <- liftIO $ runEgisonTopExpr' opts st topExpr+      (_, Just topExpr) -> do+        result <- liftIO $ fromEgisonM (desugarTopExpr topExpr >>= evalTopExpr' opts st)         case result of           Left err -> liftIO (print err) >> loop st           Right (Nothing, st') -> loop st'@@ -124,3 +144,33 @@         HeapOverflow  -> putStrLn "Heap over flow!" >> loop st         _             -> putStrLn "error!" >> loop st      )++-- |Get Egison expression from the prompt. We can handle multiline input.+getEgisonExpr :: EgisonOpts -> InputT IO (Maybe EgisonTopExpr)+getEgisonExpr opts = getEgisonExpr' opts ""+  where+    getEgisonExpr' opts prev = do+      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 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+          case parsedExpr of+            Left err | show err =~ "unexpected end of input" ->+              getEgisonExpr' opts $ input ++ "\n"+            Left err -> do+              liftIO $ print err+              getEgisonExpr opts+            Right topExpr -> do+              -- outputStr $ show topExpr+              return $ Just topExpr
hs-src/Language/Egison.hs view
@@ -38,8 +38,7 @@ import           Language.Egison.Core import           Language.Egison.Data import           Language.Egison.MathOutput  (changeOutputInLang)-import           Language.Egison.Parser      as Parser-import           Language.Egison.ParserNonS  as ParserNonS+import           Language.Egison.Parser import           Language.Egison.Primitives  import           Control.Monad.State@@ -80,27 +79,23 @@  -- |eval an Egison expression. Input is a Haskell string. runEgisonExpr :: EgisonOpts -> Env -> String -> IO (Either EgisonError EgisonValue)-runEgisonExpr opts env input-  | optSExpr opts = fromEgisonM $ Parser.readExpr input >>= evalExprDeep env-  | otherwise     = fromEgisonM $ ParserNonS.readExpr input >>= evalExprDeep env+runEgisonExpr opts env input =+  fromEgisonM $ 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-  | optSExpr opts = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr opts env-  | otherwise     = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr opts env+runEgisonTopExpr opts env input =+  fromEgisonM $ readTopExpr (optSExpr opts) input >>= evalTopExpr opts env  -- |eval an Egison top expression. Input is a Haskell string. runEgisonTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EgisonM Env -> String -> IO (Either EgisonError (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env))-runEgisonTopExpr' opts st input-  | optSExpr opts = fromEgisonM $ Parser.readTopExpr input >>= evalTopExpr' opts st-  | otherwise     = fromEgisonM $ ParserNonS.readTopExpr input >>= evalTopExpr' opts st+runEgisonTopExpr' opts st input =+  fromEgisonM $ 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-  | optSExpr opts = fromEgisonM $ Parser.readTopExprs input >>= evalTopExprs opts env-  | otherwise     = fromEgisonM $ ParserNonS.readTopExprs input >>= evalTopExprs opts env+runEgisonTopExprs opts env input =+  fromEgisonM $ readTopExprs (optSExpr opts) input >>= evalTopExprs opts env  -- |load an Egison file loadEgisonFile :: EgisonOpts -> Env -> FilePath -> IO (Either EgisonError Env)@@ -138,14 +133,13 @@   , "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/assoc.egi"-  , "lib/core/order.egi"-  , "lib/core/number.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/maybe.egi"-  , "lib/core/sexpr.egi" -- For compatibility between new and old syntax   ]
hs-src/Language/Egison/AST.hs view
@@ -32,12 +32,14 @@   , BinOpAssoc (..)   , reservedExprInfix   , reservedPatternInfix+  , findOpFrom   , stringToVar   , stringToVarExpr   ) where  import           Data.Hashable   (Hashable)-import           Data.List       (intercalate)+import           Data.List       (find, intercalate)+import           Data.Maybe      (fromJust) import           Data.List.Split (splitOn) import           Data.Text       (Text) import           GHC.Generics    (Generic)@@ -70,13 +72,11 @@   | InductiveDataExpr String [EgisonExpr]   | TupleExpr [EgisonExpr]   | CollectionExpr [InnerExpr]                -- TODO: InnerExpr should be EgisonExpr from v4.0.0-  | ArrayExpr [EgisonExpr]   | HashExpr [(EgisonExpr, EgisonExpr)]   | VectorExpr [EgisonExpr]    | LambdaExpr [Arg] EgisonExpr   | MemoizedLambdaExpr [String] EgisonExpr-  | MemoizeExpr [(EgisonExpr, EgisonExpr, EgisonExpr)] EgisonExpr   | CambdaExpr String EgisonExpr   | ProcedureExpr [String] EgisonExpr   | PatternFunctionExpr [String] EgisonPattern@@ -112,13 +112,9 @@   | PartialExpr Integer EgisonExpr   | PartialVarExpr Integer -  | GenerateArrayExpr EgisonExpr (EgisonExpr, EgisonExpr)-  | ArrayBoundsExpr EgisonExpr-  | ArrayRefExpr EgisonExpr EgisonExpr-   | GenerateTensorExpr EgisonExpr EgisonExpr   | TensorExpr EgisonExpr EgisonExpr-  | TensorContractExpr EgisonExpr EgisonExpr+  | TensorContractExpr EgisonExpr   | TensorMapExpr EgisonExpr EgisonExpr   | TensorMap2Expr EgisonExpr EgisonExpr EgisonExpr   | TransposeExpr EgisonExpr EgisonExpr@@ -246,22 +242,28 @@  reservedExprInfix :: [Infix] reservedExprInfix =-  [ makeInfix "^"  "**"        8 LeftAssoc+  [ 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 "%"  "remainder" 7 LeftAssoc+  , 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 "="  "eq?"       4 LeftAssoc-  , makeInfix "<=" "lte?"      4 LeftAssoc-  , makeInfix ">=" "gte?"      4 LeftAssoc-  , makeInfix "<"  "lt?"       4 LeftAssoc-  , makeInfix ">"  "gt?"       4 LeftAssoc-  , makeInfix "&&" "and"       3 RightAssoc-  , makeInfix "||" "or"        2 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   ]   where@@ -270,7 +272,11 @@  reservedPatternInfix :: [Infix] reservedPatternInfix =-  [ makeInfix "::" "cons" 5 RightAssoc+  [ 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@@ -278,6 +284,9 @@   where     makeInfix r f p a =       Infix { repr = r, func = f, priority = p, assoc = a, isWedge = False }++findOpFrom :: String -> [Infix] -> Infix+findOpFrom op table = fromJust $ find ((== op) . repr) table  instance Hashable (Index ()) instance Hashable Var
hs-src/Language/Egison/CmdOptions.hs view
@@ -35,7 +35,7 @@     }  defaultOption :: EgisonOpts-defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing True+defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False True False "> " Nothing False  cmdParser :: ParserInfo EgisonOpts cmdParser = info (helper <*> cmdArgParser)@@ -114,10 +114,10 @@                   <> long "math"                   <> metavar "(asciimath|latex|mathematica|maxima)"                   <> help "Output in AsciiMath, Latex, Mathematica, or Maxima format"))-            <*> flag True False-                  (short 'N'-                  <> long "new-syntax"-                  <> help "[experimental] Use non-S expression syntax")+            <*> flag False True+                  (short 'S'+                  <> long "sexpr-syntax"+                  <> help "Use s-expression syntax")  readFieldOption :: String -> (String, String) readFieldOption str =
+ hs-src/Language/Egison/Completion.hs view
@@ -0,0 +1,96 @@+{- |+Module      : Language.Egison.Completion+Licence     : MIT++This module provides command-line completion.+-}++module Language.Egison.Completion+  ( completeEgison+  ) where++import           Data.List++import           System.Console.Haskeline   hiding (catch, handle, throwTo)++-- |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++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"]++egisonKeywords :: [String]+egisonKeywords = egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral++completeParen :: Monad m => CompletionFunc m+completeParen (lstr, _) = case closeParen lstr of+  Nothing    -> return (lstr, [])+  Just paren -> return (lstr, [Completion paren paren False])++closeParen :: String -> Maybe String+closeParen str = closeParen' 0 $ removeCharAndStringLiteral str++removeCharAndStringLiteral :: String -> String+removeCharAndStringLiteral [] = []+removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':removeCharAndStringLiteral str+removeCharAndStringLiteral ('"':str) = removeCharAndStringLiteral' str+removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':removeCharAndStringLiteral str+removeCharAndStringLiteral ('\'':str) = removeCharAndStringLiteral' str+removeCharAndStringLiteral (c:str) = c:removeCharAndStringLiteral str++removeCharAndStringLiteral' :: String -> String+removeCharAndStringLiteral' []              = []+removeCharAndStringLiteral' ('"':'\\':str)  = removeCharAndStringLiteral' str+removeCharAndStringLiteral' ('"':str)       = removeCharAndStringLiteral str+removeCharAndStringLiteral' ('\'':'\\':str) = removeCharAndStringLiteral' str+removeCharAndStringLiteral' ('\'':str)      = removeCharAndStringLiteral str+removeCharAndStringLiteral' (_:str)         = removeCharAndStringLiteral' str++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
@@ -21,17 +21,10 @@     , evalRefDeep     , evalWHNF     , applyFunc-    -- * Array-    , refArray-    , arrayBounds     -- * Environment     , recursiveBind     -- * Pattern matching     , patternMatch-    -- * Collection-    , isEmptyCollection-    , unconsCollection-    , unsnocCollection     -- * Tuple, Collection     , tupleToList     , collectionToList@@ -40,11 +33,9 @@ import           Prelude                     hiding (mapM, mappend, mconcat)  import           Control.Arrow-import           Control.Monad               (when) import           Control.Monad.Except        (throwError)-import           Control.Monad.State         hiding (mapM)+import           Control.Monad.State         hiding (mapM, join) import           Control.Monad.Trans.Maybe-import           Control.Monad.Trans.State   (evalStateT, withStateT)  import           Data.Char                   (isUpper) import           Data.Foldable               (toList)@@ -55,18 +46,17 @@ import qualified Data.Sequence               as Sq import           Data.Traversable            (mapM) -import qualified Data.Array                  as Array 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      (MonadFresh(..)) import           Language.Egison.MathExpr-import           Language.Egison.Parser      as Parser-import           Language.Egison.ParserNonS  as ParserNonS+import           Language.Egison.Parser import           Language.Egison.Pretty-import           Language.Egison.Types import           Language.Egison.Tensor  --@@ -81,18 +71,14 @@     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 file ->-      if optNoIO opts-         then throwError $ Default "No IO support"-         else do exprs' <- if optSExpr opts then Parser.loadFile file-                                            else ParserNonS.loadFile file-                 collectDefs opts (exprs' ++ exprs) bindings rest-    Load file ->-      if optNoIO opts-         then throwError $ Default "No IO support"-         else do exprs' <- if optSExpr opts then Parser.loadLibraryFile file-                                            else ParserNonS.loadLibraryFile file-                 collectDefs opts (exprs' ++ exprs) bindings 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) @@ -114,11 +100,11 @@     Value (IOFunc m) -> m >> popFuncName >> return (Nothing, st)     _                -> throwError =<< TypeMismatch "io" io <$> getFuncNameStack evalTopExpr' opts st (Load file) = do-  exprs <- if optSExpr opts then Parser.loadLibraryFile file else ParserNonS.loadLibraryFile file+  exprs <- loadLibraryFile file   (bindings, _) <- collectDefs opts exprs [] []   return (Nothing, withStateT (\defines -> bindings ++ defines) st) evalTopExpr' opts st (LoadFile file) = do-  exprs <- if optSExpr opts then Parser.loadFile file else ParserNonS.loadFile file+  exprs <- loadFile file   (bindings, _) <- collectDefs opts exprs [] []   return (Nothing, withStateT (\defines -> bindings ++ defines) st) evalTopExpr' _ st InfixDecl{} = return (Nothing, st)@@ -176,10 +162,6 @@   fromInnerExpr (ElementExpr expr) = IElement <$> newObjectRef env expr   fromInnerExpr (SubCollectionExpr expr) = ISubCollection <$> newObjectRef env expr -evalExpr env (ArrayExpr exprs) = do-  refs' <- mapM (newObjectRef env) exprs-  return . Intermediate . IArray $ Array.listArray (1, toInteger (length exprs)) refs'- evalExpr env@(Env frame maybe_vwi) (VectorExpr exprs) = do   let n = toInteger (length exprs)   let indices = [1 .. (n + 1)]@@ -260,8 +242,8 @@       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 <$> refTenworWithOverride override js t-      Intermediate (ITensor t@Tensor{}) -> refTenworWithOverride override js t+      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)@@ -284,8 +266,8 @@               _ -> evalExpr env expr   case tensor of     Value (ScalarData _)              -> return tensor-    Value (TensorData t@Tensor{})     -> Value <$> refTenworWithOverride override js t-    Intermediate (ITensor t@Tensor{}) -> refTenworWithOverride override js t+    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@@ -299,8 +281,8 @@               _ -> evalExpr env expr   case tensor of     Value (ScalarData _)              -> return tensor-    Value (TensorData t@Tensor{})     -> Value <$> refTenworWithOverride override js t-    Intermediate (ITensor t@Tensor{}) -> refTenworWithOverride override js t+    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@@ -542,32 +524,8 @@           return whnf     _ -> applyFunc env func arg >>= removeDFscripts -evalExpr env (MemoizeExpr memoizeFrame expr) = do-  mapM_ (\(x, y, z) -> do x' <- evalExprDeep env x-                          case x' of-                            MemoizedFunc name ref hashRef env' names body -> do-                              indices <- evalExprDeep env y-                              indices' <- mapM fromEgison $ fromTupleValue indices-                              hash <- liftIO $ readIORef hashRef-                              ret <- evalExprDeep env z-                              retRef <- newEvaluatedObjectRef (Value ret)-                              liftIO $ writeIORef hashRef (HL.insert indices' retRef hash)-                              writeObjectRef ref (Value (MemoizedFunc name ref hashRef env' names body))-                            _ -> throwError =<< TypeMismatch "memoized-function" (Value x') <$> getFuncNameStack)-       memoizeFrame-  evalExpr env expr- evalExpr env (MatcherExpr info) = return $ Value $ UserMatcher env info -evalExpr env (GenerateArrayExpr fnExpr (fstExpr, lstExpr)) = do-  fN <- (evalExpr env fstExpr >>= fromWHNF) :: EgisonM Integer-  eN <- (evalExpr env lstExpr >>= fromWHNF) :: EgisonM Integer-  xs <- mapM (newObjectRef env . ApplyExpr fnExpr . IntegerExpr) [fN..eN]-  return $ Intermediate $ IArray $ Array.listArray (fN, eN) xs--evalExpr env (ArrayBoundsExpr expr) =-  evalExpr env expr >>= arrayBounds- evalExpr env (GenerateTensorExpr fnExpr shapeExpr) = do   shape <- evalExpr env shapeExpr >>= collectionToList   ns    <- mapM fromEgison shape :: EgisonM Shape@@ -580,21 +538,16 @@     fn <- evalExpr env' fnExpr     applyFunc env fn $ Value $ makeTuple ms -evalExpr env (TensorContractExpr fnExpr tExpr) = do-  fn <- evalExpr env fnExpr+evalExpr env (TensorContractExpr tExpr) = do   whnf <- evalExpr env tExpr   case whnf of     Intermediate (ITensor t@Tensor{}) -> do       ts <- tContract t-      tMapN (\xs -> do xs' <- mapM newEvaluatedObjectRef xs-                       applyFunc env fn (Intermediate (ITuple xs'))) ts >>= fromTensor+      makeICollection (map tensorToWHNF ts)     Value (TensorData t@Tensor{}) -> do       ts <- tContract t-      Value <$> (tMapN (applyFunc' env fn . Tuple) ts >>= fromTensor)-    _ -> return whnf- where-  applyFunc' :: Env -> WHNFData -> EgisonValue -> EgisonM EgisonValue-  applyFunc' env fn x = applyFunc env fn (Value x) >>= evalWHNF+      return $ Value $ Collection $ Sq.fromList $ map tensorToValue ts+    _ -> makeICollection [whnf]  evalExpr env (TensorMapExpr fnExpr tExpr) = do   fn <- evalExpr env fnExpr@@ -684,9 +637,6 @@ evalWHNF (Value val) = return val evalWHNF (Intermediate (IInductiveData name refs)) =   InductiveData name <$> mapM evalRefDeep refs-evalWHNF (Intermediate (IArray refs)) = do-  refs' <- mapM evalRefDeep $ Array.elems refs-  return $ Array $ Array.listArray (Array.bounds refs) refs' evalWHNF (Intermediate (IIntHash refs)) = do   refs' <- mapM evalRefDeep refs   return $ IntHash refs'@@ -719,7 +669,7 @@           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+      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@@ -791,35 +741,6 @@  refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData refArray val [] = return val-refArray (Value (Array array)) (index:indices) =-  if isInteger index-    then do i <- (fmap fromInteger . fromEgison) index-            if (\(a,b) -> a <= i && i <= b) $ Array.bounds array-              then refArray (Value (array Array.! i)) indices-              else return  $ Value Undefined-    else case index of-           ScalarData (SingleTerm 1 [(Symbol _ _ [], 1)]) -> do-             let (_,size) = Array.bounds array-             elms <- mapM (\arr -> refArray (Value arr) indices) (Array.elems array)-             elmRefs <- mapM newEvaluatedObjectRef elms-             return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs-           _  -> throwError =<< TypeMismatch "integer or symbol" (Value index) <$> getFuncNameStack-refArray (Intermediate (IArray array)) (index:indices) =-  if isInteger index-    then do i <- (fmap fromInteger . fromEgison) index-            if (\(a,b) -> a <= i && i <= b) $ Array.bounds array-              then let ref = array Array.! i in-                   evalRef ref >>= flip refArray indices-              else return  $ Value Undefined-    else case index of-           ScalarData (SingleTerm 1 [(Symbol _ _ [], 1)]) -> do-             let (_,size) = Array.bounds array-             let refs = Array.elems array-             arrs <- mapM evalRef refs-             elms <- mapM (`refArray` indices) arrs-             elmRefs <- mapM newEvaluatedObjectRef elms-             return $ Intermediate $ IArray $ Array.listArray (1, size) elmRefs-           _  -> throwError =<< TypeMismatch "integer or symbol" (Value index) <$> getFuncNameStack refArray (Value (IntHash hash)) (index:indices) = do   key <- fromEgison index   case HL.lookup key hash of@@ -852,14 +773,6 @@     Nothing  -> return $ Value Undefined refArray val _ = throwError =<< TypeMismatch "array or hash" val <$> getFuncNameStack -arrayBounds :: WHNFData -> EgisonM WHNFData-arrayBounds val = Value <$> arrayBounds' val--arrayBounds' :: WHNFData -> EgisonM EgisonValue-arrayBounds' (Intermediate (IArray arr)) = return $ Tuple [toEgison (fst (Array.bounds arr)), toEgison (snd (Array.bounds arr))]-arrayBounds' (Value (Array arr))         = return $ Tuple [toEgison (fst (Array.bounds arr)), toEgison (snd (Array.bounds arr))]-arrayBounds' val                         = throwError =<< TypeMismatch "array" val <$> getFuncNameStack- newThunk :: Env -> EgisonExpr -> Object newThunk env expr = Thunk $ evalExpr env expr @@ -1063,8 +976,14 @@   case pattern of     InductiveOrPApplyPat name args ->       case refVar env (stringToVar name) of-        Nothing -> processMState' (MState env loops seqs bindings (MAtom (InductivePat name args) target matcher:trees))-        Just _ -> processMState' (MState env loops seqs bindings (MAtom (PApplyPat (VarExpr (stringToVar name)) args) target matcher:trees))+        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:" ++ prettyS pattern@@ -1455,9 +1374,15 @@ makeITuple [x] = return x makeITuple xs  = Intermediate . ITuple <$> mapM newEvaluatedObjectRef xs +makeICollection :: [WHNFData] -> EgisonM 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.-refTenworWithOverride :: HasTensor a => Bool -> [Index EgisonValue] -> Tensor a -> EgisonM a-refTenworWithOverride override js (Tensor ns xs is) =+refTensorWithOverride :: HasTensor a => Bool -> [Index EgisonValue] -> Tensor a -> EgisonM a+refTensorWithOverride override js (Tensor ns xs is) =   tref js' (Tensor ns xs js') >>= toTensor >>= tContract' >>= fromTensor     where       js' = if override then js else is ++ js
hs-src/Language/Egison/Data.hs view
@@ -4,6 +4,9 @@ {-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE TypeOperators              #-}  {- | Module      : Language.Egison.Data@@ -32,6 +35,9 @@     , egisonToScalarData     , extractScalar     , extractScalar'+    -- * Tensor+    , tensorToWHNF+    , tensorToValue     -- * Internal data     , Object (..)     , ObjectRef@@ -60,44 +66,21 @@     , runEgisonM     , liftEgisonM     , fromEgisonM-    , FreshT (..)-    , Fresh-    , MonadFresh (..)-    , runFreshT     , MatchM     , matchFail-    , MList (..)-    , fromList-    , fromSeq-    , fromMList-    , msingleton-    , mfoldr-    , mappend-    , mconcat-    , mmap-    , mfor-    , mAny     ) where -import           Prelude                   hiding (foldr, mappend, mconcat)- import           Control.Exception import           Data.Typeable -import           Control.Monad.Except-import           Control.Monad.Fail-import           Control.Monad.Identity-import           Control.Monad.Reader      (ReaderT)-import           Control.Monad.State+import           Control.Monad.Except      hiding (join)+import           Control.Monad.State       (get, put) import           Control.Monad.Trans.Maybe-import           Control.Monad.Writer      (WriterT) -import qualified Data.Array                as Array-import           Data.Foldable             (foldr, toList)+import           Data.Foldable             (toList) import           Data.HashMap.Strict       (HashMap) import qualified Data.HashMap.Strict       as HashMap import           Data.IORef-import           Data.Monoid               (Monoid) import           Data.Sequence             (Seq) import qualified Data.Sequence             as Sq import qualified Data.Vector               as V@@ -108,9 +91,11 @@ import           Data.Ratio import           System.IO -import           System.IO.Unsafe          (unsafePerformIO)+import           Control.Egison hiding (Integer, MList, MNil, MCons, Matcher, Something, mappend)+import qualified Control.Egison as M -import           Language.Egison.AST+import           Language.Egison.AST hiding (PatVar)+import           Language.Egison.IState import           Language.Egison.MathExpr  --@@ -128,7 +113,6 @@   | InductiveData String [EgisonValue]   | Tuple [EgisonValue]   | Collection (Seq EgisonValue)-  | Array (Array.Array Integer EgisonValue)   | IntHash (HashMap Integer EgisonValue)   | CharHash (HashMap Char EgisonValue)   | StrHash (HashMap Text EgisonValue)@@ -309,9 +293,17 @@ 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@@ -334,7 +326,6 @@               | otherwise  = "(" ++ show x ++ ")"   show (Tuple vals)      = "(" ++ intercalate ", " (map show vals) ++ ")"   show (Collection vals) = "[" ++ intercalate ", " (map show (toList vals)) ++ "]"-  show (Array vals)      = "(| " ++ intercalate ", " (map show $ Array.elems vals) ++ " |)"   show (IntHash hash)  = "{|" ++ intercalate ", " (map (\(key, val) -> "[" ++ show key ++ ", " ++ show val ++ "]") $ HashMap.toList hash) ++ "|}"   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) ++ "|}"@@ -374,7 +365,6 @@  (InductiveData name vals) == (InductiveData name' vals') = (name == name') && (vals == vals')  (Tuple vals) == (Tuple vals') = vals == vals'  (Collection vals) == (Collection vals') = vals == vals'- (Array vals) == (Array vals') = vals == vals'  (IntHash vals) == (IntHash vals') = vals == vals'  (CharHash vals) == (CharHash vals') = vals == vals'  (StrHash vals) == (StrHash vals') = vals == vals'@@ -484,7 +474,6 @@     IInductiveData String [ObjectRef]   | ITuple [ObjectRef]   | ICollection (IORef (Seq Inner))-  | IArray (Array.Array Integer ObjectRef)   | IIntHash (HashMap Integer ObjectRef)   | ICharHash (HashMap Char ObjectRef)   | IStrHash (HashMap Text ObjectRef)@@ -499,12 +488,11 @@   show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>"   show (Intermediate (ITuple _)) = "[...]"   show (Intermediate (ICollection _)) = "{...}"-  show (Intermediate (IArray _)) = "(|...|)"   show (Intermediate (IIntHash _)) = "{|...|}"   show (Intermediate (ICharHash _)) = "{|...|}"   show (Intermediate (IStrHash _)) = "{|...|}"---  show (Intermediate (ITensor _)) = "[|...|]"   show (Intermediate (ITensor (Tensor ns xs _))) = "[|" ++ show (length ns) ++ show (V.length xs) ++ "|]"+  show (Intermediate (ITensor (Scalar _))) = "scalar"  instance Show Object where   show (Thunk _)   = "#<thunk>"@@ -575,7 +563,12 @@ extendEnv (Env env idx) bdg = Env ((: env) $ HashMap.fromList bdg) idx  refVar :: Env -> Var -> Maybe ObjectRef-refVar (Env env _) var = msum $ map (HashMap.lookup var) env+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@@ -629,6 +622,7 @@   | Parser String   | EgisonBug String CallStack   | MatchFailure String CallStack+  | UnknownFileExtension String   | Default String   deriving Typeable @@ -651,6 +645,10 @@   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 (Default message) = "Error: " ++ message  showTrace :: CallStack -> String@@ -685,162 +683,7 @@ fromEgisonM :: EgisonM a -> IO (Either EgisonError a) fromEgisonM = modifyCounter . runEgisonM -{-# NOINLINE counter #-}-counter :: IORef Int-counter = unsafePerformIO $ newIORef 0--readCounter :: IO Int-readCounter = readIORef counter--updateCounter :: Int -> IO ()-updateCounter = writeIORef counter--modifyCounter :: FreshT IO a -> IO a-modifyCounter m = do-  x <- readCounter-  (result, st) <- runFreshT (RuntimeState { indexCounter = x, funcNameStack = [] }) m-  updateCounter $ indexCounter st-  return result--data RuntimeState = RuntimeState-    -- index counter for generating fresh variable-      { indexCounter :: Int-    -- names of called functions for improved error message-      , funcNameStack :: [String]-      }--newtype FreshT m a = FreshT { unFreshT :: StateT RuntimeState m a }-  deriving (Functor, Applicative, Monad, MonadState RuntimeState, MonadTrans)--type Fresh = FreshT Identity--class (Applicative m, Monad m) => MonadFresh m where-  fresh :: m String-  freshV :: m Var-  pushFuncName :: String -> m ()-  topFuncName :: m String-  popFuncName :: m ()-  getFuncNameStack :: m [String]--instance (Applicative m, Monad m) => MonadFresh (FreshT m) where-  fresh = FreshT $ do-    st <- get; modify (\st -> st { indexCounter = indexCounter st + 1 })-    return $ "$_" ++ show (indexCounter st)-  freshV = FreshT $ do-    st <- get; modify (\st -> st {indexCounter = indexCounter st + 1 })-    return $ Var ["$_" ++ show (indexCounter st)] []-  pushFuncName name = FreshT $ do-    st <- get-    put $ st { funcNameStack = name : funcNameStack st }-    return ()-  topFuncName = FreshT $ head . funcNameStack <$> get-  popFuncName = FreshT $ do-    st <- get-    put $ st { funcNameStack = tail $ funcNameStack st }-    return ()-  getFuncNameStack = FreshT $ funcNameStack <$> get--instance (MonadError e m) => MonadError e (FreshT m) where-  throwError = lift . throwError-  catchError m h = FreshT $ catchError (unFreshT m) (unFreshT . h)--instance (MonadState s m) => MonadState s (FreshT m) where-  get = lift get-  put s = lift $ put s--instance (MonadFresh m) => MonadFresh (StateT s m) where-  fresh = lift fresh-  freshV = lift freshV-  pushFuncName name = lift $ pushFuncName name-  topFuncName = lift topFuncName-  popFuncName = lift popFuncName-  getFuncNameStack = lift getFuncNameStack--instance (MonadFresh m) => MonadFresh (ExceptT e m) where-  fresh = lift fresh-  freshV = lift freshV-  pushFuncName name = lift $ pushFuncName name-  topFuncName = lift topFuncName-  popFuncName = lift popFuncName-  getFuncNameStack = lift getFuncNameStack--instance (MonadFresh m, Monoid e) => MonadFresh (ReaderT e m) where-  fresh = lift fresh-  freshV = lift freshV-  pushFuncName name = lift $ pushFuncName name-  topFuncName = lift topFuncName-  popFuncName = lift popFuncName-  getFuncNameStack = lift getFuncNameStack--instance (MonadFresh m, Monoid e) => MonadFresh (WriterT e m) where-  fresh = lift fresh-  freshV = lift freshV-  pushFuncName name = lift $ pushFuncName name-  topFuncName = lift topFuncName-  popFuncName = lift popFuncName-  getFuncNameStack = lift getFuncNameStack--instance MonadIO (FreshT IO) where-  liftIO = lift--runFreshT :: Monad m => RuntimeState -> FreshT m a -> m (a, RuntimeState)-runFreshT = flip (runStateT . unFreshT)--runFresh :: RuntimeState -> Fresh a -> (a, RuntimeState)-runFresh seed m = runIdentity $ flip runStateT seed $ unFreshT m------- MList---- type MatchM = MaybeT EgisonM  matchFail :: MatchM a matchFail = MaybeT $ return Nothing--data MList m a = MNil | MCons a (m (MList m a))--instance Show a => Show (MList m a) where-  show MNil        = "MNil"-  show (MCons x _) = "(MCons " ++ show x ++ " ...)"--fromList :: Monad m => [a] -> MList m a-fromList = foldr f MNil- where f x xs = MCons x $ return xs--fromSeq :: Monad m => Seq a -> MList m a-fromSeq = foldr f MNil- where f x xs = MCons x $ return xs--fromMList :: Monad m => MList m a -> m [a]-fromMList = mfoldr f $ return []-  where f x xs = (x:) <$> xs--msingleton :: Monad m => a -> MList m a-msingleton = flip MCons $ return MNil--mfoldr :: Monad m => (a -> m b -> m b) -> m b -> MList m a -> m b-mfoldr _ init MNil         = init-mfoldr f init (MCons x xs) = f x (xs >>= mfoldr f init)--mappend :: Monad m => MList m a -> m (MList m a) -> m (MList m a)-mappend xs ys = mfoldr ((return .) . MCons) ys xs--mconcat :: Monad m => MList m (MList m a) -> m (MList m a)-mconcat = mfoldr mappend $ return MNil--mmap :: Monad m => (a -> m b) -> MList m a -> m (MList m b)-mmap f = mfoldr g $ return MNil-  where g x xs = flip MCons xs <$> f x--mfor :: Monad m => MList m a -> (a -> m b) -> m (MList m b)-mfor = flip mmap--mAny :: Monad m => (a -> m Bool) -> MList m a -> m Bool-mAny _ MNil = return False-mAny p (MCons x xs) = do-  b <- p x-  if b-   then return True-   else do xs' <- xs-           mAny p xs'
hs-src/Language/Egison/Desugar.hs view
@@ -17,12 +17,12 @@  import           Control.Monad.Except  (throwError) import           Data.Char             (toUpper)-import           Data.List             (span) import           Data.Set              (Set) import qualified Data.Set              as S  import           Language.Egison.AST import           Language.Egison.Data+import           Language.Egison.IState (fresh, freshV)  desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr desugarTopExpr (Define name expr)   = Define name <$> desugar expr@@ -118,11 +118,6 @@   name <- fresh   desugar $ LambdaExpr [TensorArg name] (MatchExpr BFSMode (stringToVarExpr name) matcher clauses) -desugar (ArrayRefExpr expr nums) =-  case nums of-    TupleExpr nums' -> desugar $ IndexedExpr True expr (map Subscript nums')-    _ -> desugar $ IndexedExpr True expr [Subscript nums]- -- TODO: Allow nested MultiSubscript and MultiSuperscript desugar (IndexedExpr b expr indices) =   case indices of@@ -160,9 +155,6 @@ desugar (PowerExpr expr1 expr2) =   (\x y -> makeApply "**" [x, y]) <$> desugar expr1 <*> desugar expr2 -desugar (ArrayBoundsExpr expr) =-  ArrayBoundsExpr <$> desugar expr- desugar (InductiveDataExpr name exprs) =   InductiveDataExpr name <$> mapM desugar exprs @@ -188,52 +180,22 @@   TensorExpr <$> desugar nsExpr <*> desugar xsExpr  desugar (LambdaExpr names expr) = do-  let (rtnames, rhnames) = span (\case-                                    TensorArg _ -> True-                                    _           -> False) (reverse names)-  case rhnames of-    [] -> LambdaExpr names <$> desugar expr-    InvertedScalarArg rhname:rhnames' ->-      case rhnames' of-        [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames)-                          (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (FlipIndicesExpr (stringToVarExpr rhname)))-        ScalarArg rhname2:rhnames2' ->-          desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2, TensorArg rhname] ++ reverse rtnames)-                      (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr)-                                      (stringToVarExpr rhname2)-                                      (FlipIndicesExpr (stringToVarExpr rhname)))-        InvertedScalarArg rhname2:rhnames2' ->-          desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2, TensorArg rhname] ++ reverse rtnames)-                      (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr)-                                      (FlipIndicesExpr (stringToVarExpr rhname2))-                                      (FlipIndicesExpr (stringToVarExpr rhname)))--    ScalarArg rhname:rhnames' -> do-      let (rtnames2, rhnames2) = span (\case-                                          TensorArg _ -> True-                                          _           -> False) rhnames'-      case rhnames2 of-        [] -> desugar $ LambdaExpr (reverse rhnames' ++ [TensorArg rhname] ++ reverse rtnames)-                          (TensorMapExpr (LambdaExpr [TensorArg rhname] expr) (stringToVarExpr rhname))-        (ScalarArg rhname2:rhnames2') ->-          desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames)-                      (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (stringToVarExpr rhname2) (stringToVarExpr rhname))-        (InvertedScalarArg rhname2:rhnames2') ->-          desugar $ LambdaExpr (reverse rhnames2' ++ [TensorArg rhname2] ++ rtnames2 ++ [TensorArg rhname] ++ reverse rtnames)-                      (TensorMap2Expr (LambdaExpr [TensorArg rhname2, TensorArg rhname] expr) (FlipIndicesExpr (stringToVarExpr rhname2)) (stringToVarExpr rhname))+  let (args', expr') = foldr desugarInvertedArgs ([], expr) names+  expr'' <- desugar expr'+  return $ LambdaExpr args' expr''+  where+    desugarInvertedArgs :: Arg -> ([Arg], EgisonExpr) -> ([Arg], EgisonExpr)+    desugarInvertedArgs (TensorArg x) (args, expr) = (TensorArg x : args, expr)+    desugarInvertedArgs (ScalarArg x) (args, expr) =+      (TensorArg x : args,+       TensorMapExpr (LambdaExpr [TensorArg x] expr) (stringToVarExpr x))+    desugarInvertedArgs (InvertedScalarArg x) (args, expr) =+      (TensorArg x : args,+       TensorMapExpr (LambdaExpr [TensorArg x] expr) (FlipIndicesExpr (stringToVarExpr x)))  desugar (MemoizedLambdaExpr names expr) =   MemoizedLambdaExpr names <$> desugar expr -desugar (MemoizeExpr memoizeBindings expr) = do-  memoizeBindings' <- mapM (\(x,y,z) -> do x' <- desugar x-                                           y' <- desugar y-                                           z' <- desugar z-                                           return (x',y',z'))-                           memoizeBindings-  expr' <- desugar expr-  return $ MemoizeExpr memoizeBindings' expr'- desugar (CambdaExpr name expr) =   CambdaExpr name <$> desugar expr @@ -273,7 +235,8 @@   IoExpr <$> desugar expr  desugar (UnaryOpExpr "-" expr) =-  (\x -> makeApply "neg" [x]) <$> desugar expr+  desugar (BinaryOpExpr mult (IntegerExpr (-1)) expr)+    where mult = findOpFrom "*" reservedExprInfix desugar (UnaryOpExpr "!" (ApplyExpr expr1 expr2)) =   WedgeApplyExpr <$> desugar expr1 <*> desugar expr2 desugar (UnaryOpExpr "'" expr) = QuoteExpr <$> desugar expr@@ -283,10 +246,18 @@   (\x y -> WedgeApplyExpr (stringToVarExpr (func op)) (TupleExpr [x, y]))     <$> desugar expr1 <*> desugar expr2 +desugar (BinaryOpExpr op expr1 expr2) | repr op == "::" =+  (\x y -> CollectionExpr [ElementExpr x, SubCollectionExpr y]) <$> desugar expr1 <*> desugar expr2+desugar (BinaryOpExpr op expr1 expr2) | repr op == "++" =+  (\x y -> CollectionExpr [SubCollectionExpr x, SubCollectionExpr y]) <$> desugar expr1 <*> desugar expr2 desugar (BinaryOpExpr op expr1 expr2) =   (\x y -> makeApply (func 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) = do   x <- fresh   y <- fresh@@ -308,18 +279,15 @@ desugar (SeqExpr expr0 expr1) =   SeqExpr <$> desugar expr0 <*> desugar expr1 -desugar (GenerateArrayExpr fnExpr (fstExpr, lstExpr)) = do-  fnExpr' <- desugar fnExpr-  fstExpr' <- desugar fstExpr-  lstExpr' <- desugar lstExpr-  return $ GenerateArrayExpr fnExpr' (fstExpr', lstExpr')- desugar (GenerateTensorExpr fnExpr sizeExpr) =   GenerateTensorExpr <$> desugar fnExpr <*> desugar sizeExpr -desugar (TensorContractExpr fnExpr tExpr) =-  TensorContractExpr <$> desugar fnExpr <*> desugar tExpr+desugar (TensorContractExpr tExpr) =+  TensorContractExpr <$> desugar tExpr +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 @@ -366,7 +334,7 @@ desugarIndex index = traverse desugar index  desugarPattern :: EgisonPattern -> EgisonM EgisonPattern-desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' pattern+desugarPattern pattern = LetPat (map makeBinding $ S.elems $ collectName pattern) <$> desugarPattern' (desugarPatternInfix pattern)  where    collectNames :: [EgisonPattern] -> Set String    collectNames patterns = S.unions $ map collectName patterns@@ -394,14 +362,50 @@    makeBinding :: String -> BindingExpr    makeBinding name = ([stringToVar name], HashExpr []) +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+ desugarPattern' :: EgisonPattern -> EgisonM 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' (InfixPat Infix{ repr = "&" } pattern1 pattern2) = AndPat <$> mapM desugarPattern' [pattern1, pattern2]-desugarPattern' (InfixPat Infix{ repr = "|" } pattern1 pattern2) = OrPat  <$> mapM desugarPattern' [pattern1, pattern2]-desugarPattern' (InfixPat Infix{ func = f } pattern1 pattern2)   = InductivePat f <$> mapM desugarPattern' [pattern1, pattern2] desugarPattern' (AndPat patterns) = AndPat <$> mapM desugarPattern' patterns desugarPattern' (OrPat patterns)  =  OrPat <$> mapM desugarPattern' patterns desugarPattern' (TuplePat patterns)  = TuplePat <$> mapM desugarPattern' patterns@@ -418,31 +422,30 @@   pat2' <- desugarPattern' pattern2   return $ InductivePat "div" [pat1', pat2'] desugarPattern' (PlusPat patterns) = do-  pats' <- mapM desugarPattern' (concatMap f patterns)+  pats' <- mapM desugarPattern' (concatMap flatten patterns)   case reverse pats' of     [] -> return $ InductivePat "plus" [ValuePat (IntegerExpr 0)]     lp:hps ->-      return $ InductivePat "plus" [foldr (\p r -> InductivePat "cons" [p, r]) lp (reverse hps)]+      return $ InductivePat "plus" [foldr (\p acc -> InductivePat "cons" [p, acc]) lp (reverse hps)]  where-   f (PlusPat xs) = concatMap f xs-   f pat          = [pat]-desugarPattern' (MultPat (intPat:patterns)) = do-  intPat' <- desugarPattern' intPat-  pats' <- mapM desugarPattern' (concatMap f patterns)+   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 ->-      return $ InductivePat "mult" [intPat',-                                    foldr (\p r -> case p of-                                                     PowerPat p1 p2 -> InductivePat "ncons" [p1, p2, r]-                                                     _ -> InductivePat "cons" [p, r])-                                          (case lp of-                                             PowerPat p1 p2 -> InductivePat "ncons" [p1, p2, ValuePat (IntegerExpr 1)]-                                             _ -> lp)-                                          (reverse hps)]+    [] -> 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-   f (MultPat xs) = concatMap f xs-   f pat          = [pat]+   flatten (MultPat xs) = concatMap flatten xs+   flatten pat          = [pat] desugarPattern' (PowerPat pattern1 pattern2) = PowerPat <$> desugarPattern' pattern1 <*> desugarPattern' pattern2 desugarPattern' pattern = return pattern
+ hs-src/Language/Egison/IState.hs view
@@ -0,0 +1,115 @@+{-# 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(..)+  , FreshT(..)+  , Fresh+  , MonadFresh(..)+  , runFreshT+  , runFresh+  , modifyCounter+  ) where++import           Control.Monad.Except+import           Control.Monad.Identity+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]+  }++newtype FreshT m a = FreshT { unFreshT :: StateT IState m a }+  deriving (Functor, Applicative, Monad, MonadState IState, MonadTrans)++type Fresh = FreshT Identity++class (Applicative m, Monad m) => MonadFresh m where+  fresh :: m String+  freshV :: m Var+  pushFuncName :: String -> m ()+  topFuncName :: m String+  popFuncName :: m ()+  getFuncNameStack :: m [String]++instance (Applicative m, Monad m) => MonadFresh (FreshT m) where+  fresh = FreshT $ do+    st <- get; modify (\st -> st { indexCounter = indexCounter st + 1 })+    return $ "$_" ++ show (indexCounter st)+  freshV = FreshT $ do+    st <- get; modify (\st -> st {indexCounter = indexCounter st + 1 })+    return $ Var ["$_" ++ show (indexCounter st)] []+  pushFuncName name = FreshT $ do+    st <- get+    put $ st { funcNameStack = name : funcNameStack st }+    return ()+  topFuncName = FreshT $ head . funcNameStack <$> get+  popFuncName = FreshT $ do+    st <- get+    put $ st { funcNameStack = tail $ funcNameStack st }+    return ()+  getFuncNameStack = FreshT $ funcNameStack <$> get++instance (MonadState s m) => MonadState s (FreshT m) where+  get = lift get+  put s = lift $ put s++instance (MonadFresh m) => MonadFresh (StateT s m) where+  fresh = lift fresh+  freshV = lift freshV+  pushFuncName name = lift $ pushFuncName name+  topFuncName = lift topFuncName+  popFuncName = lift popFuncName+  getFuncNameStack = lift getFuncNameStack++instance (MonadFresh m) => MonadFresh (ExceptT e m) where+  fresh = lift fresh+  freshV = lift freshV+  pushFuncName name = lift $ pushFuncName name+  topFuncName = lift topFuncName+  popFuncName = lift popFuncName+  getFuncNameStack = lift getFuncNameStack++instance MonadIO (FreshT IO) where+  liftIO = lift++runFreshT :: Monad m => IState -> FreshT m a -> m (a, IState)+runFreshT = flip (runStateT . unFreshT)++runFresh :: IState -> Fresh a -> (a, IState)+runFresh seed m = runIdentity $ flip runStateT seed $ unFreshT m++{-# NOINLINE counter #-}+counter :: IORef Int+counter = unsafePerformIO $ newIORef 0++readCounter :: IO Int+readCounter = readIORef counter++updateCounter :: Int -> IO ()+updateCounter = writeIORef counter++modifyCounter :: FreshT IO a -> IO a+modifyCounter m = do+  x <- readCounter+  (result, st) <- runFreshT (IState { indexCounter = x, funcNameStack = [] }) m+  updateCounter $ indexCounter st+  return result
+ hs-src/Language/Egison/MList.hs view
@@ -0,0 +1,70 @@+{- |+Module      : Language.Egison.MList+Licence     : MIT++This module provides definition and utility functions for monadic list.+-}++module Language.Egison.MList+  ( MList (..)+  , fromList+  , fromSeq+  , fromMList+  , msingleton+  , mfoldr+  , mappend+  , mconcat+  , mmap+  , mfor+  , mAny+  ) where++import           Prelude       hiding (mappend, mconcat,)+import           Data.Sequence (Seq)++data MList m a = MNil | MCons a (m (MList m a))++instance Show a => Show (MList m a) where+  show MNil        = "MNil"+  show (MCons x _) = "(MCons " ++ show x ++ " ...)"++fromList :: Monad m => [a] -> MList m a+fromList = foldr f MNil+ where f x xs = MCons x $ return xs++fromSeq :: Monad m => Seq a -> MList m a+fromSeq = foldr f MNil+ where f x xs = MCons x $ return xs++fromMList :: Monad m => MList m a -> m [a]+fromMList = mfoldr f $ return []+  where f x xs = (x:) <$> xs++msingleton :: Monad m => a -> MList m a+msingleton = flip MCons $ return MNil++mfoldr :: Monad m => (a -> m b -> m b) -> m b -> MList m a -> m b+mfoldr _ init MNil         = init+mfoldr f init (MCons x xs) = f x (xs >>= mfoldr f init)++mappend :: Monad m => MList m a -> m (MList m a) -> m (MList m a)+mappend xs ys = mfoldr ((return .) . MCons) ys xs++mconcat :: Monad m => MList m (MList m a) -> m (MList m a)+mconcat = mfoldr mappend $ return MNil++mmap :: Monad m => (a -> m b) -> MList m a -> m (MList m b)+mmap f = mfoldr g $ return MNil+  where g x xs = flip MCons xs <$> f x++mfor :: Monad m => MList m a -> (a -> m b) -> m (MList m b)+mfor = flip mmap++mAny :: Monad m => (a -> m Bool) -> MList m a -> m Bool+mAny _ MNil = return False+mAny p (MCons x xs) = do+  b <- p x+  if b+   then return True+   else do xs' <- xs+           mAny p xs'
hs-src/Language/Egison/MathExpr.hs view
@@ -31,7 +31,7 @@     ) where  import           Prelude                   hiding (foldr, mappend, mconcat)-import           Data.List                 (any, elemIndex, intercalate, splitAt)+import           Data.List                 (elemIndex, intercalate)  import           Language.Egison.AST @@ -97,33 +97,59 @@                     Nothing -> False   _ == _ = False +class Complex a where+  isAtom :: a -> Bool++show' :: (Complex a, Show a) => a -> String+show' e | isAtom e = show e+show' e            = "(" ++ show e ++ ")"++instance Complex ScalarData where+  isAtom (Div p (Plus [Term 1 []])) = isAtom p+  isAtom _                          = False++instance Complex PolyExpr where+  isAtom (Plus [])           = True+  isAtom (Plus [Term _ []])  = True+  isAtom (Plus [Term 1 [_]]) = True+  isAtom _                   = False++instance Complex SymbolExpr where+  isAtom Symbol{}     = True+  isAtom (Apply _ []) = True+  isAtom _            = False+ instance Show ScalarData where   show (Div p1 (Plus [Term 1 []])) = show p1-  show (Div p1 p2)                 = show' p1 ++ " / " ++ show' p2+  show (Div p1 p2)                 = show'' p1 ++ " / " ++ show' p2     where-      show' :: PolyExpr -> String-      show' p@(Plus [_]) = show p-      show' p            = "(" ++ show p ++ ")"+      show'' :: PolyExpr -> String+      show'' p@(Plus [_]) = show p+      show'' p            = "(" ++ show p ++ ")"  instance Show PolyExpr where-  show (Plus [])  = "0"-  show (Plus ts)  = intercalate " + " (map show ts)+  show (Plus []) = "0"+  show (Plus (t:ts)) = show t ++ concatMap showWithSign ts+    where+      showWithSign (Term a xs) | a < 0 = " - " ++ show (Term (- a) xs)+      showWithSign t                   = " + " ++ show t  instance Show TermExpr where   show (Term a []) = show a   show (Term 1 xs) = intercalate " * " (map showPoweredSymbol xs)+  show (Term (-1) xs) = "- " ++ intercalate " * " (map showPoweredSymbol xs)   show (Term a xs) = intercalate " * " (show a : map showPoweredSymbol xs)  showPoweredSymbol :: (SymbolExpr, Integer) -> String showPoweredSymbol (x, 1) = show x-showPoweredSymbol (x, n) = show x ++ "^" ++ show n+showPoweredSymbol (x, n) = show' x ++ "^" ++ show n  instance Show SymbolExpr where   show (Symbol _ (':':':':':':_) []) = "#"   show (Symbol _ s []) = s   show (Symbol _ s js) = s ++ concatMap show js-  show (Apply fn mExprs) = "(" ++ show fn ++ " " ++ unwords (map show mExprs) ++ ")"-  show (Quote mExprs) = "'(" ++ show mExprs ++ ")"+  show (Apply fn mExprs) = unwords (map show' (fn : mExprs))+  show (Quote mExprs) = "'" ++ show' mExprs   show (FunctionData name _ _ js) = show name ++ concatMap show js  instance Show (Index ScalarData) where
hs-src/Language/Egison/Parser.hs view
@@ -1,88 +1,59 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections    #-}-{-# OPTIONS_GHC -Wno-all      #-} -- Since we will soon deprecate this parser- {- | Module      : Language.Egison.Parser Licence     : MIT -This module provide Egison parser.+This module provides the parser interface. -}  module Language.Egison.Parser        (-       -- * Parse a string+       -- * Parse and desugar          readTopExprs        , readTopExpr        , readExprs        , readExpr-       , parseTopExprs-       , parseTopExpr-       , parseExprs-       , parseExpr-       -- * Parse a file+       -- * Parse and desugar a file        , loadLibraryFile        , loadFile        ) where--import           Control.Applicative     (pure, (*>), (<$>), (<*), (<*>))-import           Control.Monad.Except    (liftIO, throwError)-import           Control.Monad.Identity  (Identity, unless)--import           Data.Char               (isLower, isUpper)-import           Data.Either-import           Data.Functor            (($>))-import           Data.List.Split         (splitOn)-import           Data.Ratio-import qualified Data.Set                as Set-import qualified Data.Text               as T+ +import           Control.Monad.Except           (liftIO, throwError)+import           Control.Monad.State            (unless) -import           Text.Parsec-import           Text.Parsec.String-import qualified Text.Parsec.Token       as P-import           System.Directory        (doesFileExist, getHomeDirectory)+import           System.Directory               (doesFileExist, getHomeDirectory) import           System.IO  import           Language.Egison.AST import           Language.Egison.Desugar import           Language.Egison.Data-import           Paths_egison            (getDataFileName)--readTopExprs :: String -> EgisonM [EgisonTopExpr]-readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs--readTopExpr :: String -> EgisonM EgisonTopExpr-readTopExpr = either throwError desugarTopExpr . parseTopExpr--readExprs :: String -> EgisonM [EgisonExpr]-readExprs = either throwError (mapM desugarExpr) . parseExprs--readExpr :: String -> EgisonM EgisonExpr-readExpr = either throwError desugarExpr . parseExpr+import qualified Language.Egison.Parser.SExpr   as SExpr+import qualified Language.Egison.Parser.NonS    as NonS+import           Paths_egison                   (getDataFileName) -parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]-parseTopExprs = doParse $ do-  ret <- whiteSpace >> endBy topExpr whiteSpace-  eof-  return ret+readTopExprs :: Bool -> String -> EgisonM [EgisonTopExpr]+readTopExprs useSExpr =+  either throwError (mapM desugarTopExpr) . parseTopExprs+    where parseTopExprs | useSExpr  = SExpr.parseTopExprs+                        | otherwise = NonS.parseTopExprs -parseTopExpr :: String -> Either EgisonError EgisonTopExpr-parseTopExpr = doParse $ do-  ret <- whiteSpace >> topExpr-  whiteSpace >> eof-  return ret+-- TODO(momohatt): Parse from the last state+readTopExpr :: Bool -> String -> EgisonM EgisonTopExpr+readTopExpr useSExpr =+  either throwError desugarTopExpr . parseTopExpr+    where parseTopExpr | useSExpr  = SExpr.parseTopExpr+                       | otherwise = NonS.parseTopExpr -parseExprs :: String -> Either EgisonError [EgisonExpr]-parseExprs = doParse $ do-  ret <- whiteSpace >> endBy expr whiteSpace-  eof-  return ret+readExprs :: Bool -> String -> EgisonM [EgisonExpr]+readExprs useSExpr =+  either throwError (mapM desugarExpr) . parseExprs+    where parseExprs | useSExpr  = SExpr.parseExprs+                     | otherwise = NonS.parseExprs -parseExpr :: String -> Either EgisonError EgisonExpr-parseExpr = doParse $ do-  ret <- whiteSpace >> expr-  whiteSpace >> eof-  return ret+readExpr :: Bool -> String -> EgisonM EgisonExpr+readExpr useSExpr =+  either throwError desugarExpr . parseExpr+    where parseExpr | useSExpr  = SExpr.parseExpr+                    | otherwise = NonS.parseExpr  -- |Load a libary file loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]@@ -99,7 +70,8 @@   doesExist <- liftIO $ doesFileExist file   unless doesExist $ throwError $ Default ("file does not exist: " ++ file)   input <- liftIO $ readUTF8File file-  exprs <- readTopExprs $ shebang input+  useSExpr <- checkIfUseSExpr file+  exprs <- readTopExprs useSExpr $ shebang input   concat <$> mapM recursiveLoad exprs  where   recursiveLoad (Load file)     = loadLibraryFile file@@ -115,813 +87,14 @@   hSetEncoding h utf8   hGetContents h ------ 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 -> a-doParse' p input = case doParse p input of-                     Right x -> x------- Expressions----topExpr :: Parser EgisonTopExpr-topExpr = try (Test <$> expr)-      <|> try defineExpr-      <|> try (parens (redefineExpr-                   <|> 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--testExpr :: Parser EgisonTopExpr-testExpr = keywordTest >> Test <$> expr--executeExpr :: Parser EgisonTopExpr-executeExpr = keywordExecute >> Execute <$> expr--loadFileExpr :: Parser EgisonTopExpr-loadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral--loadExpr :: Parser EgisonTopExpr-loadExpr = keywordLoad >> Load <$> stringLiteral--expr :: Parser EgisonExpr-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]-                                  parseindex = many1 (try (MultiSubscript   <$> (char '_' >> expr') <*> (string "..._" >> expr'))-                                                  <|> try (MultiSuperscript <$> (char '~' >> expr') <*> (string "...~" >> expr'))-                                                  <|> try (Subscript    <$> (char '_' >> expr'))-                                                  <|> try (Superscript  <$> (char '~' >> expr'))-                                                  <|> try (SupSubscript <$> (string "~_" >> expr'))-                                                  <|> try (Userscript   <$> (char '|' >> expr')))---quoteExpr :: Parser EgisonExpr-quoteExpr = char '\'' >> QuoteExpr <$> expr'--expr' :: Parser EgisonExpr-expr' = try partialExpr-            <|> try constantExpr-            <|> try partialVarExpr-            <|> try freshVarExpr-            <|> try varExpr-            <|> inductiveDataExpr-            <|> try arrayExpr-            <|> try vectorExpr-            <|> try tupleExpr-            <|> try hashExpr-            <|> collectionExpr-            <|> quoteSymbolExpr-            <|> wedgeExpr-            <|> parens (ifExpr-                        <|> lambdaExpr-                        <|> memoizedLambdaExpr-                        <|> memoizeExpr-                        <|> cambdaExpr-                        <|> procedureExpr-                        <|> patternFunctionExpr-                        <|> letRecExpr-                        <|> letExpr-                        <|> letStarExpr-                        <|> withSymbolsExpr-                        <|> doExpr-                        <|> ioExpr-                        <|> matchAllExpr-                        <|> matchAllDFSExpr-                        <|> matchExpr-                        <|> matchDFSExpr-                        <|> matchAllLambdaExpr-                        <|> matchLambdaExpr-                        <|> matcherExpr-                        <|> seqExpr-                        <|> applyExpr-                        <|> cApplyExpr-                        <|> algebraicDataMatcherExpr-                        <|> generateArrayExpr-                        <|> arrayBoundsExpr-                        <|> arrayRefExpr-                        <|> generateTensorExpr-                        <|> tensorExpr-                        <|> tensorContractExpr-                        <|> tensorMapExpr-                        <|> tensorMap2Expr-                        <|> transposeExpr-                        <|> subrefsExpr-                        <|> suprefsExpr-                        <|> userrefsExpr-                        <|> functionWithArgExpr-                        )-            <?> "expression"--varExpr :: Parser EgisonExpr-varExpr = VarExpr <$> identVarWithoutIndex--freshVarExpr :: Parser EgisonExpr-freshVarExpr = char '#' >> return FreshVarExpr--inductiveDataExpr :: Parser EgisonExpr-inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy expr whiteSpace--tupleExpr :: Parser EgisonExpr-tupleExpr = brackets $ TupleExpr <$> sepEndBy expr whiteSpace--collectionExpr :: Parser EgisonExpr-collectionExpr = braces $ CollectionExpr <$> sepEndBy innerExpr whiteSpace- where-  innerExpr :: Parser InnerExpr-  innerExpr = (char '@' >> SubCollectionExpr <$> expr)-               <|> ElementExpr <$> expr--arrayExpr :: Parser EgisonExpr-arrayExpr = between lp rp $ ArrayExpr <$> sepEndBy expr whiteSpace-  where-    lp = P.lexeme lexer (string "(|")-    rp = string "|)"--vectorExpr :: Parser EgisonExpr-vectorExpr = between lp rp $ VectorExpr <$> sepEndBy expr whiteSpace-  where-    lp = P.lexeme lexer (string "[|")-    rp = string "|]"--hashExpr :: Parser EgisonExpr-hashExpr = between lp rp $ HashExpr <$> sepEndBy pairExpr whiteSpace-  where-    lp = P.lexeme lexer (string "{|")-    rp = string "|}"-    pairExpr :: Parser (EgisonExpr, EgisonExpr)-    pairExpr = brackets $ (,) <$> expr <*> expr--wedgeExpr :: Parser EgisonExpr-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)-  where-    lp = P.lexeme lexer (char '[')-    rp = char ']'--quoteSymbolExpr :: Parser EgisonExpr-quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr--matchAllExpr :: Parser EgisonExpr-matchAllExpr = keywordMatchAll >> MatchAllExpr BFSMode <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses)--matchAllDFSExpr :: Parser EgisonExpr-matchAllDFSExpr = keywordMatchAllDFS >> MatchAllExpr DFSMode <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses)--matchExpr :: Parser EgisonExpr-matchExpr = keywordMatch >> MatchExpr BFSMode <$> expr <*> expr <*> matchClauses--matchDFSExpr :: Parser EgisonExpr-matchDFSExpr = keywordMatchDFS >> MatchExpr DFSMode <$> expr <*> expr <*> matchClauses--matchAllLambdaExpr :: Parser EgisonExpr-matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> (((:[]) <$> matchClause) <|> matchClauses)--matchLambdaExpr :: Parser EgisonExpr-matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses--matchClauses :: Parser [MatchClause]-matchClauses = braces $ sepEndBy matchClause whiteSpace--matchClause :: Parser MatchClause-matchClause = brackets $ (,) <$> pattern <*> expr--matcherExpr :: Parser EgisonExpr-matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses--ppMatchClauses :: Parser [PatternDef]-ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace--ppMatchClause :: Parser PatternDef-ppMatchClause = brackets $ (,,) <$> ppPattern <*> expr <*> pdMatchClauses--pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)]-pdMatchClauses = braces $ sepEndBy pdMatchClause whiteSpace--pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr)-pdMatchClause = brackets $ (,) <$> pdPattern <*> expr--ppPattern :: Parser PrimitivePatPattern-ppPattern = P.lexeme lexer (ppWildCard-                        <|> ppPatVar-                        <|> ppValuePat-                        <|> ppInductivePat-                        <|> ppTuplePat-                        <?> "primitive-pattren-pattern")--ppWildCard :: Parser PrimitivePatPattern-ppWildCard = reservedOp "_" $> PPWildCard--ppPatVar :: Parser PrimitivePatPattern-ppPatVar = reservedOp "$" $> PPPatVar--ppValuePat :: Parser PrimitivePatPattern-ppValuePat = reservedOp ",$" >> PPValuePat <$> ident--ppInductivePat :: Parser PrimitivePatPattern-ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace)--ppTuplePat :: Parser PrimitivePatPattern-ppTuplePat = brackets $ PPTuplePat <$> sepEndBy ppPattern whiteSpace--pdPattern :: Parser PrimitiveDataPattern-pdPattern = P.lexeme lexer pdPattern'--pdPattern' :: Parser PrimitiveDataPattern-pdPattern' = reservedOp "_" $> PDWildCard-                    <|> (char '$' >> PDPatVar <$> ident)-                    <|> braces ((PDConsPat <$> pdPattern <*> (char '@' *> pdPattern))-                            <|> (PDSnocPat <$> (char '@' *> pdPattern) <*> pdPattern)-                            <|> pure PDEmptyPat)-                    <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern whiteSpace)-                    <|> brackets (PDTuplePat <$> sepEndBy pdPattern whiteSpace)-                    <|> PDConstantPat <$> constantExpr-                    <?> "primitive-data-pattern"--ifExpr :: Parser EgisonExpr-ifExpr = keywordIf >> IfExpr <$> expr <*> expr <*> expr--lambdaExpr :: Parser EgisonExpr-lambdaExpr = keywordLambda >> LambdaExpr <$> argNames <*> expr--memoizedLambdaExpr :: Parser EgisonExpr-memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <*> expr--memoizeExpr :: Parser EgisonExpr-memoizeExpr = keywordMemoize >> MemoizeExpr <$> memoizeFrame <*> expr--memoizeFrame :: Parser [(EgisonExpr, EgisonExpr, EgisonExpr)]-memoizeFrame = braces $ sepEndBy memoizeBinding whiteSpace--memoizeBinding :: Parser (EgisonExpr, EgisonExpr, EgisonExpr)-memoizeBinding = brackets $ (,,) <$> expr <*> expr <*> expr--cambdaExpr :: Parser EgisonExpr-cambdaExpr = keywordCambda >> char '$' >> CambdaExpr <$> ident <*> expr--procedureExpr :: Parser EgisonExpr-procedureExpr = keywordProcedure >> ProcedureExpr <$> varNames <*> expr--patternFunctionExpr :: Parser EgisonExpr-patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern--letRecExpr :: Parser EgisonExpr-letRecExpr =  keywordLetRec >> LetRecExpr <$> bindings <*> expr--letExpr :: Parser EgisonExpr-letExpr = keywordLet >> LetExpr <$> bindings <*> expr--letStarExpr :: Parser EgisonExpr-letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <*> expr--withSymbolsExpr :: Parser EgisonExpr-withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident whiteSpace) <*> expr--doExpr :: Parser EgisonExpr-doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (stringToVarExpr "return") (TupleExpr [])) expr--statements :: Parser [BindingExpr]-statements = braces $ sepEndBy statement whiteSpace--statement :: Parser BindingExpr-statement = try binding-        <|> try (brackets (([],) <$> expr))-        <|> (([],) <$> expr)--bindings :: Parser [BindingExpr]-bindings = braces $ sepEndBy binding whiteSpace--binding :: Parser BindingExpr-binding = brackets $ (,) <$> 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)--argNames :: Parser [Arg]-argNames = return <$> argName-            <|> brackets (sepEndBy argName whiteSpace)--argName :: Parser Arg-argName = try (ScalarArg <$> (char '$' >> ident))-      <|> try (InvertedScalarArg <$> (string "*$" >> ident))-      <|> try (TensorArg <$> (char '%' >> ident))--ioExpr :: Parser EgisonExpr-ioExpr = keywordIo >> IoExpr <$> expr--seqExpr :: Parser EgisonExpr-seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr--cApplyExpr :: Parser EgisonExpr-cApplyExpr = keywordCApply >> CApplyExpr <$> expr <*> expr--applyExpr :: Parser EgisonExpr-applyExpr = do-  func <- expr-  args <- sepEndBy arg whiteSpace-  let vars = lefts args-  case vars of-    [] -> return . ApplyExpr func . TupleExpr $ rights args-    _ | all null vars ->-        let n = toInteger (length vars)-            args' = f args 1-         in return $ PartialExpr n $ ApplyExpr func (TupleExpr args')-      | all (not . null) vars ->-        let ns = Set.fromList $ map read vars-            n = Set.size ns-        in if Set.findMin ns == 1 && Set.findMax ns == n-             then-               let args' = map g args-                in return $ PartialExpr (toInteger n) $ ApplyExpr func (TupleExpr args')-             else fail "invalid partial application"-      | otherwise -> fail "invalid partial application"- where-  arg = try (Right <$> expr)-         <|> char '$' *> (Left <$> option "" index)-  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit-  annonVars m n = take n $ map ((':':) . show) [m..]-  f [] n                   = []-  f (Left _ : args) n      = PartialVarExpr n : f args (n + 1)-  f (Right expr : args) n  = expr : f args n-  g (Left arg)   = PartialVarExpr (read arg)-  g (Right expr) = expr--partialExpr :: Parser EgisonExpr-partialExpr = (PartialExpr . read <$> index) <*> (char '#' >> expr)- where-  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit--partialVarExpr :: Parser EgisonExpr-partialVarExpr = char '%' >> PartialVarExpr <$> integerLiteral--algebraicDataMatcherExpr :: Parser EgisonExpr-algebraicDataMatcherExpr = keywordAlgebraicDataMatcher-                                >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 inductivePat' whiteSpace)-  where-    inductivePat' :: Parser (String, [EgisonExpr])-    inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace--generateArrayExpr :: Parser EgisonExpr-generateArrayExpr = keywordGenerateArray >> GenerateArrayExpr <$> expr <*> arrayRange--arrayRange :: Parser (EgisonExpr, EgisonExpr)-arrayRange = brackets $ (,) <$> expr <*> expr--arrayBoundsExpr :: Parser EgisonExpr-arrayBoundsExpr = keywordArrayBounds >> ArrayBoundsExpr <$> expr--arrayRefExpr :: Parser EgisonExpr-arrayRefExpr = keywordArrayRef >> ArrayRefExpr <$> expr <*> expr--generateTensorExpr :: Parser EgisonExpr-generateTensorExpr = keywordGenerateTensor >> GenerateTensorExpr <$> expr <*> expr--tensorExpr :: Parser EgisonExpr-tensorExpr = keywordTensor >> TensorExpr <$> expr <*> expr--tensorContractExpr :: Parser EgisonExpr-tensorContractExpr = keywordTensorContract >> TensorContractExpr <$> expr <*> expr--tensorMapExpr :: Parser EgisonExpr-tensorMapExpr = keywordTensorMap >> TensorMapExpr <$> expr <*> expr--tensorMap2Expr :: Parser EgisonExpr-tensorMap2Expr = keywordTensorMap2 >> TensorMap2Expr <$> expr <*> expr <*> expr--transposeExpr :: Parser EgisonExpr-transposeExpr = keywordTranspose >> TransposeExpr <$> expr <*> expr--subrefsExpr :: Parser EgisonExpr-subrefsExpr = (keywordSubrefs >> SubrefsExpr False <$> expr <*> expr)-               <|> (keywordSubrefsNew >> SubrefsExpr True <$> expr <*> expr)--suprefsExpr :: Parser EgisonExpr-suprefsExpr = (keywordSuprefs >> SuprefsExpr False <$> expr <*> expr)-               <|> (keywordSuprefsNew >> SuprefsExpr True <$> expr <*> expr)--userrefsExpr :: Parser EgisonExpr-userrefsExpr = (keywordUserrefs >> UserrefsExpr False <$> expr <*> expr)-                <|> (keywordUserrefsNew >> UserrefsExpr True <$> expr <*> expr)---- Patterns--pattern :: Parser EgisonPattern-pattern = P.lexeme lexer (do pattern <- pattern'-                             option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> expr'))--pattern' :: Parser EgisonPattern-pattern' = wildCard-            <|> contPat-            <|> patVar-            <|> varPat-            <|> valuePat-            <|> predPat-            <|> notPat-            <|> tuplePat-            <|> inductivePat-            <|> laterPatVar-            <|> try seqNilPat-            <|> try seqConsPat-            <|> try seqPat-            <|> parens (andPat-                    <|> notPat'-                    <|> orPat-                    <|> loopPat-                    <|> letPat-                    <|> try divPat-                    <|> try plusPat-                    <|> try multPat-                    <|> try dApplyPat-                    <|> try pApplyPat-                    )--pattern'' :: Parser EgisonPattern-pattern'' = wildCard-            <|> patVar-            <|> valuePat--wildCard :: Parser EgisonPattern-wildCard = reservedOp "_" >> pure WildCard--patVar :: Parser EgisonPattern-patVar = char '$' >> PatVar <$> identVarWithoutIndex--varPat :: Parser EgisonPattern-varPat = VarPat <$> ident--valuePat :: Parser EgisonPattern-valuePat = char ',' >> ValuePat <$> expr--predPat :: Parser EgisonPattern-predPat = char '?' >> PredPat <$> expr--letPat :: Parser EgisonPattern-letPat = keywordLet >> LetPat <$> bindings <*> pattern--notPat :: Parser EgisonPattern-notPat = char '!' >> NotPat <$> pattern--notPat' :: Parser EgisonPattern-notPat' = keywordNot >> NotPat <$> pattern--tuplePat :: Parser EgisonPattern-tuplePat = brackets $ TuplePat <$> sepEndBy pattern whiteSpace--inductivePat :: Parser EgisonPattern-inductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy pattern whiteSpace--contPat :: Parser EgisonPattern-contPat = keywordCont >> pure ContPat--andPat :: Parser EgisonPattern-andPat = (reservedOp "&" <|> keywordAnd) >> AndPat <$> sepEndBy pattern whiteSpace--orPat :: Parser EgisonPattern-orPat = (reservedOp "|" <|> keywordOr) >> OrPat <$> sepEndBy pattern whiteSpace--pApplyPat :: Parser EgisonPattern-pApplyPat = PApplyPat <$> expr <*> sepEndBy pattern whiteSpace--dApplyPat :: Parser EgisonPattern-dApplyPat = DApplyPat <$> pattern'' <*> sepEndBy pattern whiteSpace--loopPat :: Parser EgisonPattern-loopPat = keywordLoop >> char '$' >> LoopPat <$> identVarWithoutIndex <*> 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)))--seqNilPat :: Parser EgisonPattern-seqNilPat = braces $ pure SeqNilPat--seqConsPat :: Parser EgisonPattern-seqConsPat = braces $ SeqConsPat <$> pattern <*> (char '@' >> pattern)--seqPat :: Parser EgisonPattern-seqPat = braces $ do-  pats <- sepEndBy pattern whiteSpace-  tailPat <- option SeqNilPat (char '@' >> pattern)-  return $ foldr SeqConsPat tailPat pats--laterPatVar :: Parser EgisonPattern-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-                 <|> (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-  char '.'-  mStr <- many1 digit-  let m = read mStr-  let l = m % (10 ^ fromIntegral (length mStr))-  if n < 0 then return (fromRational (fromIntegral n - l) :: Double)-           else return (fromRational (fromIntegral n + l) :: Double)------- Tokens-----egisonDef :: P.GenLanguageDef String () Identity-egisonDef =-  P.LanguageDef { P.commentStart       = "#|"-                , P.commentEnd         = "|#"-                , P.commentLine        = ";"-                , P.identStart         = letter <|> symbol1 <|> symbol0-                , P.identLetter        = letter <|> digit <|> symbol2-                , P.opStart            = symbol1-                , P.opLetter           = symbol1-                , P.reservedNames      = reservedKeywords-                , P.reservedOpNames    = reservedOperators-                , P.nestedComments     = True-                , P.caseSensitive      = True }--symbol0 = char '^'--- Don't allow three consecutive dots to be a part of identifier-symbol1 = oneOf "+-*/=∂∇" <|> try (char '.' <* notFollowedBy (string ".."))-symbol2 = symbol1 <|> oneOf "'!?₀₁₂₃₄₅₆₇₈₉"--lexer :: P.GenTokenParser String () Identity-lexer = P.makeTokenParser egisonDef--reservedKeywords :: [String]-reservedKeywords =-  [ "define"-  , "redefine"-  , "set!"-  , "test"-  , "execute"-  , "load-file"-  , "load"-  , "if"-  , "seq"-  , "capply"-  , "lambda"-  , "memoized-lambda"-  , "memoize"-  , "cambda"-  , "procedure"-  , "pattern-function"-  , "letrec"-  , "let"-  , "let*"-  , "with-symbols"---  , "not"---  , "and"---  , "or"-  , "loop"-  , "match-all"-  , "match"-  , "match-all-dfs"-  , "match-dfs"-  , "match-all-lambda"-  , "match-lambda"-  , "matcher"-  , "do"-  , "io"-  , "algebraic-data-matcher"-  , "generate-array"-  , "array-bounds"-  , "array-ref"-  , "generate-tensor"-  , "tensor"-  , "contract"-  , "tensor-map"-  , "tensor-map2"-  , "transpose"-  , "subrefs"-  , "subrefs!"-  , "suprefs"-  , "suprefs!"-  , "user-refs"-  , "user-refs!"-  , "function"-  , "something"-  , "undefined"]--reservedOperators :: [String]-reservedOperators =-  [ "$"-  , ",$"-  , "_"-  , "^"-  , "&"-  , "|*"---  , "'"---  , "~"---  , "!"---  , ","---  , "@"-  , "..."]--reserved :: String -> Parser ()-reserved = P.reserved lexer--reservedOp :: String -> Parser ()-reservedOp = P.reservedOp lexer--keywordDefine               = reserved "define"-keywordRedefine             = reserved "redefine"-keywordSet                  = reserved "set!"-keywordTest                 = reserved "test"-keywordExecute              = reserved "execute"-keywordLoadFile             = reserved "load-file"-keywordLoad                 = reserved "load"-keywordIf                   = reserved "if"-keywordNot                  = reserved "not"-keywordAnd                  = reserved "and"-keywordOr                   = reserved "or"-keywordSeq                  = reserved "seq"-keywordCApply               = reserved "capply"-keywordLambda               = reserved "lambda"-keywordMemoizedLambda       = reserved "memoized-lambda"-keywordMemoize              = reserved "memoize"-keywordCambda               = reserved "cambda"-keywordProcedure            = reserved "procedure"-keywordPatternFunction      = reserved "pattern-function"-keywordLetRec               = reserved "letrec"-keywordLet                  = reserved "let"-keywordLetStar              = reserved "let*"-keywordWithSymbols          = reserved "with-symbols"-keywordLoop                 = reserved "loop"-keywordCont                 = reserved "..."-keywordMatchAll             = reserved "match-all"-keywordMatchAllDFS          = reserved "match-all-dfs"-keywordMatchAllLambda       = reserved "match-all-lambda"-keywordMatch                = reserved "match"-keywordMatchDFS             = reserved "match-dfs"-keywordMatchLambda          = reserved "match-lambda"-keywordMatcher              = reserved "matcher"-keywordDo                   = reserved "do"-keywordIo                   = reserved "io"-keywordSomething            = reserved "something"-keywordUndefined            = reserved "undefined"-keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher"-keywordGenerateArray        = reserved "generate-array"-keywordArrayBounds          = reserved "array-bounds"-keywordArrayRef             = reserved "array-ref"-keywordGenerateTensor       = reserved "generate-tensor"-keywordTensor               = reserved "tensor"-keywordTensorContract       = reserved "contract"-keywordTensorMap            = reserved "tensor-map"-keywordTensorMap2           = reserved "tensor-map2"-keywordTranspose            = reserved "transpose"-keywordSubrefs              = reserved "subrefs"-keywordSubrefsNew           = reserved "subrefs!"-keywordSuprefs              = reserved "suprefs"-keywordSuprefsNew           = reserved "suprefs!"-keywordUserrefs             = reserved "user-refs"-keywordUserrefsNew          = reserved "user-refs!"-keywordFunction             = reserved "function"--sign :: Num a => Parser (a -> a)-sign = (char '-' >> return negate)-   <|> (char '+' >> return id)-   <|> return id--integerLiteral :: Parser Integer-integerLiteral = sign <*> P.natural lexer--stringLiteral :: Parser String-stringLiteral = P.stringLiteral lexer--charLiteral :: Parser Char-charLiteral = P.charLiteral lexer--oneChar :: Parser Char-oneChar = do-  string "c#"-  x <- (char '\\' >> anyChar >>= (\x -> return ['\\', x])) <|> (anyChar >>= (\x -> return [x]))-  return $ doParse' charLiteral $ "'" ++ x ++ "'"--boolLiteral :: Parser Bool-boolLiteral = char '#' >> (char 't' $> True <|> char 'f' $> False)--whiteSpace :: Parser ()-whiteSpace = P.whiteSpace lexer--parens :: Parser a -> Parser a-parens = P.parens lexer--brackets :: Parser a -> Parser a-brackets = P.brackets lexer--braces :: Parser a -> Parser a-braces = P.braces lexer--angles :: Parser a -> Parser a-angles = P.angles lexer--ident :: Parser String-ident = 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)--indexForVar :: Parser (Index String)-indexForVar = try (char '~' >> Superscript <$> ident)-        <|> try (char '_' >> Subscript <$> ident)--indexType :: Parser (Index ())-indexType = try (char '~' >> return (Superscript ()))-        <|> try (char '_' >> return (Subscript ()))--upperName :: Parser String-upperName = P.lexeme lexer upperName'--upperName' :: Parser String-upperName' = (:) <$> upper <*> option "" ident- where-  upper :: Parser Char-  upper = satisfy isUpper+hasDotEgiExtension :: String -> Bool+hasDotEgiExtension file = drop (length file - 4) file == ".egi" -lowerName :: Parser String-lowerName = P.lexeme lexer lowerName'+hasDotSEgiExtension :: String -> Bool+hasDotSEgiExtension file = drop (length file - 5) file == ".segi" -lowerName' :: Parser String-lowerName' = (:) <$> lower <*> option "" ident- where-  lower :: Parser Char-  lower = satisfy isLower+checkIfUseSExpr :: String -> EgisonM Bool+checkIfUseSExpr file+  | hasDotEgiExtension file  = return False+  | hasDotSEgiExtension file = return True+  | otherwise                = throwError (UnknownFileExtension file)
+ hs-src/Language/Egison/Parser/NonS.hs view
@@ -0,0 +1,949 @@+{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE NamedFieldPuns   #-}++{- |+Module      : Language.Egison.Parser.NonS+Licence     : MIT++This module provides the new parser of Egison.+-}++module Language.Egison.Parser.NonS+       (+       -- * Parse a string+         parseTopExprs+       , parseTopExpr+       , parseExprs+       , parseExpr+       ) where++import           Control.Monad.Except           (throwError)+import           Control.Monad.State            (evalStateT, get, put, StateT)++import           Data.Char                      (isAsciiUpper, isLetter)+import           Data.Either                    (isRight)+import           Data.Functor                   (($>))+import           Data.List                      (groupBy, insertBy)+import           Data.Maybe                     (isJust, isNothing)+import           Data.Text                      (pack)++import           Control.Monad.Combinators.Expr+import           Text.Megaparsec+import           Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer     as L++import           Language.Egison.AST+import           Language.Egison.Data++parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]+parseTopExprs = doParse $ many (L.nonIndented sc topExpr) <* eof++parseTopExpr :: String -> Either EgisonError EgisonTopExpr+parseTopExpr = doParse $ sc >> topExpr <* eof++parseExprs :: String -> Either EgisonError [EgisonExpr]+parseExprs = doParse $ many (L.nonIndented sc expr) <* eof++parseExpr :: String -> Either EgisonError EgisonExpr+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+                       }++data CustomError+  = IllFormedSection Infix Infix+  | IllFormedDefine+  deriving (Eq, Ord)++instance ShowErrorComponent CustomError where+  showErrorComponent (IllFormedSection op op') =+    "The operator " ++ info op ++ " must have lower precedence than " ++ info op'+    where+      info op =+         "'" ++ repr op ++ "' [" ++ show (assoc op) ++ " " ++ show (priority op) ++ "]"+  showErrorComponent IllFormedDefine =+    "Failed to parse the left hand side of definition 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++--+-- Expressions+--++topExpr :: Parser EgisonTopExpr+topExpr = Load     <$> (reserved "load" >> stringLiteral)+      <|> LoadFile <$> (reserved "loadFile" >> stringLiteral)+      <|> Execute  <$> (reserved "execute" >> expr)+      <|> infixExpr+      <|> defineOrTestExpr+      <?> "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+  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) }++infixExpr :: Parser EgisonTopExpr+infixExpr = do+  assoc     <- (reserved "infixl" $> LeftAssoc)+           <|> (reserved "infixr" $> RightAssoc)+           <|> (reserved "infix"  $> NonAssoc)+  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 }+  addNewOp newop isPattern+  return (InfixDecl isPattern newop)+  where+    check :: String -> Parser String+    check ('!':_) = fail $ "cannot declare infix starting with '!'"+    check x | x `elem` reservedOp = fail $ show x ++ " cannot be a new infix"+            | otherwise           = return x++    -- Checks if given string is valid for pattern op.+    checkP :: String -> Parser String+    checkP x | x `elem` reservedPOp = fail $ show x ++ " cannot be a new pattern infix"+             | otherwise           = return x++    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 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@(BinaryOpExpr 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 (BinaryOpExpr 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 (BinaryOpExpr 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 (BinaryOpExpr op lhs rhs) | repr op == "%" = do+      lhs' <- exprToArgs lhs+      rhs' <- exprToArgs rhs+      case rhs' of+        TensorArg _ : _ -> return (lhs' ++ rhs')+        _               -> Nothing+    exprToArgs _ = Nothing++expr :: Parser EgisonExpr+expr = do+  body <- exprWithoutWhere+  bindings <- optional (reserved "where" >> alignSome binding)+  return $ case bindings of+             Nothing -> body+             Just bindings -> LetRecExpr bindings body++exprWithoutWhere :: Parser EgisonExpr+exprWithoutWhere =+       ifExpr+   <|> patternMatchExpr+   <|> lambdaExpr+   <|> lambdaLikeExpr+   <|> letExpr+   <|> withSymbolsExpr+   <|> doExpr+   <|> ioExpr+   <|> seqExpr+   <|> capplyExpr+   <|> matcherExpr+   <|> algebraicDataMatcherExpr+   <|> tensorExpr+   <|> functionExpr+   <|> refsExpr+   <|> opExpr+   <?> "expression"++-- Also parses atomExpr+opExpr :: Parser EgisonExpr+opExpr = do+  infixes <- exprInfix <$> get+  makeExprParser atomOrApplyExpr (makeExprTable infixes)++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'+  where+    -- notFollowedBy (in unary and binary) is necessary for section expression.+    unary :: String -> Parser (EgisonExpr -> EgisonExpr)+    unary sym = UnaryOpExpr <$> try (operator sym <* notFollowedBy (symbol ")"))++    binary :: Infix -> Parser (EgisonExpr -> EgisonExpr -> EgisonExpr)+    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 $ BinaryOpExpr op++    toOperator :: Infix -> Operator Parser EgisonExpr+    toOperator = infixToOperator binary+++ifExpr :: Parser EgisonExpr+ifExpr = reserved "if" >> IfExpr <$> expr <* reserved "then" <*> expr <* reserved "else" <*> expr++patternMatchExpr :: Parser EgisonExpr+patternMatchExpr = makeMatchExpr (reserved "match")       (MatchExpr BFSMode)+               <|> makeMatchExpr (reserved "matchDFS")    (MatchExpr DFSMode)+               <|> makeMatchExpr (reserved "matchAll")    (MatchAllExpr BFSMode)+               <|> makeMatchExpr (reserved "matchAllDFS") (MatchAllExpr DFSMode)+               <?> "pattern match expression"+  where+    makeMatchExpr keyword ctor = ctor <$> (keyword >> expr)+                                      <*> (reserved "as" >> expr)+                                      <*> (reserved "with" >> matchClauses1)++-- Parse more than 1 match clauses.+matchClauses1 :: Parser [MatchClause]+matchClauses1 =+  -- If the first bar '|' is missing, then it is expected to have only one match clause.+  (lookAhead (symbol "|") >> alignSome matchClause) <|> (:[]) <$> matchClauseWithoutBar+  where+    matchClauseWithoutBar :: Parser MatchClause+    matchClauseWithoutBar = (,) <$> pattern <*> (symbol "->" >> expr)++    matchClause :: Parser MatchClause+    matchClause = (,) <$> (symbol "|" >> pattern) <*> (symbol "->" >> expr)++lambdaExpr :: Parser EgisonExpr+lambdaExpr = symbol "\\" >> (+      makeMatchLambdaExpr (reserved "match")    MatchLambdaExpr+  <|> makeMatchLambdaExpr (reserved "matchAll") MatchAllLambdaExpr+  <|> try (LambdaExpr <$> tupleOrSome arg <* symbol "->") <*> expr+  <|> PatternFunctionExpr <$> tupleOrSome lowerId <*> (symbol "=>" >> pattern))+  <?> "lambda or pattern function expression"+  where+    makeMatchLambdaExpr keyword ctor = do+      matcher <- keyword >> reserved "as" >> expr+      clauses <- reserved "with" >> matchClauses1+      return $ ctor matcher clauses++lambdaLikeExpr :: Parser EgisonExpr+lambdaLikeExpr =+        (reserved "memoizedLambda" >> MemoizedLambdaExpr <$> tupleOrSome lowerId <*> (symbol "->" >> expr))+    <|> (reserved "procedure"      >> ProcedureExpr      <$> 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+  <?> "argument"++letExpr :: Parser EgisonExpr+letExpr = do+  binds <- reserved "let" >> oneLiner <|> alignSome binding+  body  <- reserved "in" >> expr+  return $ LetRecExpr binds body+  where+    oneLiner :: Parser [BindingExpr]+    oneLiner = braces $ sepBy binding (symbol ";")++binding :: Parser BindingExpr+binding = do+  (vars, args) <- (,[]) <$> parens (sepBy varLiteral comma)+              <|> do var <- varLiteral+                     args <- many arg+                     return ([var], args)+  body <- symbol ":=" >> expr+  return $ case args of+             [] -> (vars, body)+             _  -> (vars, LambdaExpr args body)++withSymbolsExpr :: Parser EgisonExpr+withSymbolsExpr = WithSymbolsExpr <$> (reserved "withSymbols" >> brackets (sepBy ident comma)) <*> expr++doExpr :: Parser EgisonExpr+doExpr = do+  stmts <- reserved "do" >> oneLiner <|> alignSome statement+  return $ case last stmts of+             ([], retExpr@(ApplyExpr (VarExpr (Var ["return"] _)) _)) ->+               DoExpr (init stmts) retExpr+             _ -> DoExpr stmts (makeApply' "return" [])+  where+    statement :: Parser BindingExpr+    statement = (reserved "let" >> binding) <|> ([],) <$> expr++    oneLiner :: Parser [BindingExpr]+    oneLiner = braces $ sepBy statement (symbol ";")++ioExpr :: Parser EgisonExpr+ioExpr = IoExpr <$> (reserved "io" >> expr)++seqExpr :: Parser EgisonExpr+seqExpr = SeqExpr <$> (reserved "seq" >> atomExpr) <*> atomExpr++capplyExpr :: Parser EgisonExpr+capplyExpr = CApplyExpr <$> (reserved "capply" >> atomExpr) <*> atomExpr++matcherExpr :: Parser EgisonExpr+matcherExpr = do+  reserved "matcher"+  -- Assuming it is unlikely that users want to write matchers with only 1+  -- pattern definition, the first '|' (bar) is made indispensable in matcher+  -- expression.+  MatcherExpr <$> alignSome (symbol "|" >> patternDef)+  where+    patternDef :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])+    patternDef = do+      pp <- ppPattern+      returnMatcher <- reserved "as" >> expr <* reserved "with"+      datapat <- alignSome (symbol "|" >> dataCases)+      return (pp, returnMatcher, datapat)++    dataCases :: Parser (PrimitiveDataPattern, EgisonExpr)+    dataCases = (,) <$> pdPattern <*> (symbol "->" >> expr)++algebraicDataMatcherExpr :: Parser EgisonExpr+algebraicDataMatcherExpr = do+  reserved "algebraicDataMatcher"+  AlgebraicDataMatcherExpr <$> alignSome (symbol "|" >> patternDef)+  where+    patternDef = indentBlock lowerId atomExpr++tensorExpr :: Parser EgisonExpr+tensorExpr =+      (reserved "tensor"         >> TensorExpr         <$> atomExpr <*> atomExpr)+  <|> (reserved "generateTensor" >> GenerateTensorExpr <$> atomExpr <*> atomExpr)+  <|> (reserved "contract"       >> TensorContractExpr <$> atomExpr)+  <|> (reserved "tensorMap"      >> TensorMapExpr      <$> atomExpr <*> atomExpr)+  <|> (reserved "tensorMap2"     >> TensorMap2Expr     <$> atomExpr <*> atomExpr <*> atomExpr)+  <|> (reserved "transpose"      >> TransposeExpr      <$> atomExpr <*> atomExpr)++functionExpr :: Parser EgisonExpr+functionExpr = FunctionExpr <$> (reserved "function" >> parens (sepBy expr comma))++refsExpr :: Parser EgisonExpr+refsExpr =+      (reserved "subrefs"   >> SubrefsExpr  False <$> atomExpr <*> atomExpr)+  <|> (reserved "subrefs!"  >> SubrefsExpr  True  <$> atomExpr <*> atomExpr)+  <|> (reserved "suprefs"   >> SuprefsExpr  False <$> atomExpr <*> atomExpr)+  <|> (reserved "suprefs!"  >> SuprefsExpr  True  <$> atomExpr <*> atomExpr)+  <|> (reserved "userRefs"  >> UserrefsExpr False <$> atomExpr <*> atomExpr)+  <|> (reserved "userRefs!" >> UserrefsExpr True  <$> atomExpr <*> atomExpr)++collectionExpr :: Parser EgisonExpr+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]++    elementsExpr = CollectionExpr <$> (sepBy (ElementExpr <$> 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 = 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]+    -- 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 = do+      infixes <- exprInfix <$> get+      op      <- choice $ map (infixLiteral . repr) infixes+      rarg    <- optional expr+      case rarg of+        Just (BinaryOpExpr op' _ _)+          | assoc op' /= RightAssoc && 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 = do+      infixes <- exprInfix <$> get+      larg    <- opExpr+      op      <- choice $ map (infixLiteral . repr) infixes+      case larg of+        BinaryOpExpr op' _ _+          | assoc op' /= LeftAssoc && priority op >= priority op' ->+          customFailure (IllFormedSection op op')+        _ -> return (SectionExpr op (Just larg) Nothing)++vectorExpr :: Parser EgisonExpr+vectorExpr = VectorExpr <$> between (symbol "[|") (symbol "|]") (sepEndBy expr comma)++hashExpr :: Parser EgisonExpr+hashExpr = HashExpr <$> hashBraces (sepEndBy hashElem comma)+  where+    hashBraces = between (symbol "{|") (symbol "|}")+    hashElem = parens $ (,) <$> expr <*> (comma >> expr)++index :: Parser (Index EgisonExpr)+index = SupSubscript <$> (string "~_" >> atomExpr')+    <|> try (char '_' >> subscript)+    <|> try (char '~' >> superscript)+    <|> try (Userscript <$> (char '|' >> atomExpr'))+    <?> "index"+  where+    subscript = do+      e1 <- atomExpr'+      e2 <- optional (string "..._" >> atomExpr')+      case e2 of+        Nothing  -> return $ Subscript e1+        Just e2' -> return $ MultiSubscript e1 e2'+    superscript = do+      e1 <- atomExpr'+      e2 <- optional (string "...~" >> atomExpr')+      case e2 of+        Nothing  -> return $ Superscript e1+        Just e2' -> return $ MultiSuperscript e1 e2'++atomOrApplyExpr :: Parser EgisonExpr+atomOrApplyExpr = do+  (func, args) <- indentBlock atomExpr atomExpr+  return $ case args of+             [] -> func+             _  -> makeApply func args++-- (Possibly indexed) atomic expressions+atomExpr :: Parser EgisonExpr+atomExpr = do+  e <- atomExpr'+  override <- isNothing <$> optional (try (string "..." <* lookAhead index))+  indices <- many index+  return $ case indices of+             [] -> e+             _  -> IndexedExpr override e indices++-- Atomic expressions without index+atomExpr' :: Parser EgisonExpr+atomExpr' = partialExpr    -- must come before |constantExpr|+        <|> constantExpr+        <|> FreshVarExpr <$ symbol "#"+        <|> VarExpr <$> varLiteral+        <|> vectorExpr     -- must come before |collectionExpr|+        <|> collectionExpr+        <|> tupleOrParenExpr+        <|> hashExpr+        <|> QuoteExpr <$> (char '\'' >> atomExpr') -- must come after |constantExpr|+        <|> QuoteSymbolExpr <$> (char '`' >> atomExpr')+        <|> PartialVarExpr  <$> try (char '%' >> positiveIntegerLiteral)+        <?> "atomic expression"++partialExpr :: Parser EgisonExpr+partialExpr = do+  n    <- try (L.decimal <* char '#') -- No space after the index+  body <- atomExpr                    -- No space after '#'+  return $ PartialExpr n body++constantExpr :: Parser EgisonExpr+constantExpr = numericExpr+           <|> BoolExpr <$> boolLiteral+           <|> CharExpr <$> try charLiteral        -- try for quoteExpr+           <|> StringExpr . pack <$> stringLiteral+           <|> SomethingExpr <$ reserved "something"+           <|> UndefinedExpr <$ reserved "undefined"++numericExpr :: Parser EgisonExpr+numericExpr = FloatExpr <$> try positiveFloatLiteral+          <|> IntegerExpr <$> positiveIntegerLiteral+          <?> "numeric expression"+--+-- Pattern+--++pattern :: Parser EgisonPattern+pattern = letPattern+      <|> forallPattern+      <|> loopPattern+      <|> opPattern+      <?> "pattern"++letPattern :: Parser EgisonPattern+letPattern =+  reserved "let" >> LetPat <$> alignSome binding <*> (reserved "in" >> pattern)++forallPattern :: Parser EgisonPattern+forallPattern =+  reserved "forall" >> ForallPat <$> atomPattern <*> atomPattern++loopPattern :: Parser EgisonPattern+loopPattern =+  LoopPat <$> (reserved "loop" >> patVarLiteral) <*> loopRange+          <*> atomPattern <*> atomPattern+  where+    loopRange :: Parser LoopRange+    loopRange =+      parens $ do start <- expr+                  ends  <- option (defaultEnds start) (try $ comma >> expr)+                  as    <- option WildCard (comma >> pattern)+                  return $ LoopRange start ends as++    defaultEnds s =+      ApplyExpr (stringToVarExpr "from")+                (makeApply (stringToVarExpr "-'") [s, IntegerExpr 1])++seqPattern :: Parser EgisonPattern+seqPattern = do+  pats <- braces $ sepBy pattern comma+  return $ foldr SeqConsPat SeqNilPat pats++opPattern :: Parser EgisonPattern+opPattern = do+  ops <- patternInfix <$> get+  makeExprParser applyOrAtomPattern (makePatternTable ops)++makePatternTable :: [Infix] -> [[Operator Parser EgisonPattern]]+makePatternTable ops =+  let infixes = map toOperator ops+   in map (map snd) (groupBy (\x y -> fst x == fst y) infixes)+  where+    toOperator :: Infix -> (Int, Operator Parser EgisonPattern)+    toOperator op = (priority op, infixToOperator binary op)++    binary :: Infix -> Parser (EgisonPattern -> EgisonPattern -> EgisonPattern)+    binary op = do+      op <- try (indented >> patInfixLiteral (repr op))+      return $ InfixPat op++applyOrAtomPattern :: Parser EgisonPattern+applyOrAtomPattern = (do+    (func, args) <- indentBlock (try atomPattern) atomPattern+    case (func, args) of+      (_,                 []) -> return func+      (InductivePat x [], _)  -> return $ InductiveOrPApplyPat x args+      _                       -> return $ DApplyPat func args)+  <|> (do+    (func, args) <- indentBlock atomExpr atomPattern+    return $ PApplyPat func args)++collectionPattern :: Parser EgisonPattern+collectionPattern = brackets $ do+  elems <- sepBy pattern comma+  return $ foldr (InfixPat consOp) nilPat elems+    where+      nilPat = InductivePat "nil" []+      consOp = findOpFrom "::" reservedPatternInfix++-- (Possibly indexed) atomic pattern+atomPattern :: Parser EgisonPattern+atomPattern = do+  pat     <- atomPattern'+  indices <- many . try $ char '_' >> atomExpr'+  return $ case indices of+             [] -> pat+             _  -> IndexedPat pat indices++-- Atomic pattern without index+atomPattern' :: Parser EgisonPattern+atomPattern' = WildCard <$  symbol "_"+           <|> PatVar   <$> patVarLiteral+           <|> NotPat   <$> (symbol "!" >> atomPattern)+           <|> ValuePat <$> (char '#' >> atomExpr)+           <|> collectionPattern+           <|> InductivePat <$> lowerId <*> pure []+           <|> VarPat   <$> (char '~' >> lowerId)+           <|> PredPat  <$> (symbol "?" >> atomExpr)+           <|> ContPat  <$ symbol "..."+           <|> makeTupleOrParen pattern TuplePat+           <|> seqPattern+           <|> LaterPatVar <$ symbol "@"+           <?> "atomic pattern"++ppPattern :: Parser PrimitivePatPattern+ppPattern = PPInductivePat <$> lowerId <*> many ppAtom+        <|> do ops <- patternInfix <$> get+               makeExprParser ppAtom (makeTable ops)+        <?> "primitive pattern pattern"+  where+    makeTable :: [Infix] -> [[Operator Parser PrimitivePatPattern]]+    makeTable ops =+      map (map toOperator) (groupBy (\x y -> priority x == priority y) ops)++    toOperator :: Infix -> Operator Parser PrimitivePatPattern+    toOperator = infixToOperator inductive2++    inductive2 op = (\x y -> PPInductivePat (func op) [x, y]) <$ operator (repr op)++    ppAtom :: Parser PrimitivePatPattern+    ppAtom = PPWildCard <$ symbol "_"+         <|> PPPatVar   <$ symbol "$"+         <|> PPValuePat <$> (string "#$" >> lowerId)+         <|> PPInductivePat "nil" [] <$ (symbol "[" >> symbol "]")+         <|> makeTupleOrParen ppPattern PPTuplePat++pdPattern :: Parser PrimitiveDataPattern+pdPattern = makeExprParser pdApplyOrAtom table+        <?> "primitive data pattern"+  where+    table :: [[Operator Parser PrimitiveDataPattern]]+    table =+      [ [ InfixR (PDConsPat <$ symbol "::") ]+      ]++    pdApplyOrAtom :: Parser PrimitiveDataPattern+    pdApplyOrAtom = PDInductivePat <$> upperId <*> many pdAtom+                <|> PDSnocPat <$> (symbol "snoc" >> pdAtom) <*> pdAtom+                <|> pdAtom++    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+--++-- Space Comsumer+sc :: Parser ()+sc = L.space space1 lineCmnt blockCmnt+  where+    lineCmnt  = L.skipLineComment "--"+    blockCmnt = L.skipBlockCommentNested "{-" "-}"++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++positiveIntegerLiteral :: Parser Integer+positiveIntegerLiteral = lexeme L.decimal+                     <?> "unsinged integer"++charLiteral :: Parser Char+charLiteral = between (char '\'') (symbol "\'") L.charLiteral+          <?> "character"++stringLiteral :: Parser String+stringLiteral = char '\"' *> manyTill L.charLiteral (symbol "\"")+          <?> "string"++boolLiteral :: Parser Bool+boolLiteral = reserved "True"  $> True+          <|> reserved "False" $> False+          <?> "boolean"++positiveFloatLiteral :: Parser Double+positiveFloatLiteral = lexeme L.float+           <?> "unsigned float"++varLiteral :: Parser Var+varLiteral = stringToVar <$> ident++patVarLiteral :: Parser Var+patVarLiteral = stringToVar <$> (char '$' >> ident)++-- Parse infix (binary operator) literal.+-- If the operator is prefixed with '!', |isWedge| is turned to true.+infixLiteral :: String -> Parser Infix+infixLiteral sym =+  try (do wedge   <- optional (char '!')+          opSym   <- operator' sym+          infixes <- exprInfix <$> get+          let opInfo = findOpFrom opSym infixes+          return $ opInfo { isWedge = isJust wedge })+   <?> "infix"+  where+    -- operator without try+    operator' :: String -> Parser String+    operator' sym = string sym <* notFollowedBy opChar <* sc++reserved :: String -> Parser ()+reserved w = (lexeme . try) (string w *> notFollowedBy identChar)++symbol :: String -> Parser ()+symbol sym = try (L.symbol sc sym) >> pure ()++operator :: String -> Parser String+operator sym = try $ string sym <* notFollowedBy opChar <* sc++-- |infixLiteral| for pattern infixes.+patInfixLiteral :: String -> Parser Infix+patInfixLiteral sym =+  try (do opSym <- string sym <* notFollowedBy patOpChar <* sc+          infixes <- patternInfix <$> get+          let opInfo = findOpFrom opSym infixes+          return opInfo)++-- Characters that can consist expression operators.+opChar :: Parser Char+opChar = oneOf ("%^&*-+\\|:<>?!./'#@$" ++ "∧")++-- Characters that can consist pattern operators.+-- ! ? # @ $ are omitted because they can appear at the beginning of atomPattern+patOpChar :: Parser Char+patOpChar = oneOf "%^&*-+\\|:<>./'"++newPatOp :: Parser String+newPatOp = (:) <$> patOpChar <*> many (patOpChar <|> oneOf "!?#@$")++-- Characters that consist identifiers.+-- Note that 'alphaNumChar' can also parse greek letters.+identChar :: Parser Char+identChar = alphaNumChar+        <|> oneOf (['?', '\'', '/'] ++ mathSymbols)++identString :: Parser String+identString = do+  strs <- many substr+  return $ concat strs+  where+    substr = ((:) <$> try (char '.' <* notFollowedBy (char '.')) <*> many opChar)+         <|> (:[]) <$> identChar++-- Non-alphabetical symbols that are allowed for identifiers+mathSymbols :: String+mathSymbols = "∂∇"++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++brackets :: Parser a -> Parser a+brackets  = between (symbol "[") (symbol "]")++comma :: Parser ()+comma = symbol ","++-- Notes on identifiers:+-- * Identifiers must be able to include greek letters and some symbols in+--   |mathSymbols|.+-- * Only identifiers starting with capital English letters ('A' - 'Z') can be+--   parsed as |upperId|. Identifiers starting with capital Greek letters must+--   be regarded as |lowerId|.++lowerId :: Parser String+lowerId = (lexeme . try) (p >>= check)+  where+    p = (:) <$> satisfy checkHead <*> identString+    checkHead c = c `elem` mathSymbols || isLetter c && not (isAsciiUpper c)+    check x = if x `elem` lowerReservedWords+                then fail $ "keyword " ++ show x ++ " cannot be an identifier"+                else return x++upperId :: Parser String+upperId = (lexeme . try) (p >>= check)+  where+    p = (:) <$> satisfy isAsciiUpper <*> many alphaNumChar+    check x = if x `elem` upperReservedWords+                then fail $ "keyword " ++ show x ++ " cannot be an identifier"+                else return x++-- union of lowerId and upperId+ident :: Parser String+ident = (lexeme . 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"+  , "False"+  ]++lowerReservedWords :: [String]+lowerReservedWords =+  [ "loadFile"+  , "load"+  , "if"+  , "then"+  , "else"+  , "seq"+  , "capply"+  , "memoizedLambda"+  , "cambda"+  , "procedure"+  , "let"+  , "in"+  , "where"+  , "withSymbols"+  , "loop"+  , "forall"+  , "match"+  , "matchDFS"+  , "matchAll"+  , "matchAllDFS"+  , "as"+  , "with"+  , "matcher"+  , "do"+  , "io"+  , "something"+  , "undefined"+  , "algebraicDataMatcher"+  , "generateTensor"+  , "tensor"+  , "contract"+  , "tensorMap"+  , "tensorMap2"+  , "transpose"+  , "subrefs"+  , "subrefs!"+  , "suprefs"+  , "suprefs!"+  , "userRefs"+  , "userRefs!"+  , "function"+  , "infixl"+  , "infixr"+  , "infix"+  ]++--+-- Utils+--++makeTupleOrParen :: Parser a -> ([a] -> a) -> Parser a+makeTupleOrParen parser tupleCtor = do+  elems <- parens $ sepBy parser comma+  case elems of+    [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++indentGuardGT :: Pos -> Parser Pos+indentGuardGT pos = L.indentGuard sc GT pos++-- Variant of 'some' that requires every element to be at the same indentation level+alignSome :: Parser a -> Parser [a]+alignSome p = do+  pos <- L.indentLevel+  some (indentGuardEQ pos >> p)++-- Useful for parsing syntax like function applications, where all 'arguments'+-- should be indented deeper than the 'function'.+indentBlock :: Parser a -> Parser b -> Parser (a, [b])+indentBlock phead parg = do+  pos  <- L.indentLevel+  head <- phead+  args <- many (indentGuardGT pos >> parg)+  return (head, args)++indented :: Parser Pos+indented = indentGuardGT pos1++infixToOperator :: (Infix -> Parser (a -> a -> a)) -> Infix -> Operator Parser a+infixToOperator opToParser op =+  case assoc op of+    LeftAssoc  -> InfixL (opToParser op)+    RightAssoc -> InfixR (opToParser op)+    NonAssoc   -> InfixN (opToParser op)++tupleOrSome :: Parser a -> Parser [a]+tupleOrSome p = parens (sepBy p comma) <|> some p
+ hs-src/Language/Egison/Parser/SExpr.hs view
@@ -0,0 +1,854 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections    #-}+{-# OPTIONS_GHC -Wno-all      #-} -- Since we will soon deprecate this parser++{- |+Module      : Language.Egison.Parser.SExpr+Licence     : MIT++This module provides Egison parser.+-}++module Language.Egison.Parser.SExpr+       (+       -- * Parse a string+         parseTopExprs+       , parseTopExpr+       , parseExprs+       , parseExpr+       ) where++import           Control.Applicative     (pure, (*>), (<$>), (<*), (<*>))+import           Control.Monad.Except    (throwError)+import           Control.Monad.Identity  (Identity)++import           Data.Char               (isLower, isUpper, toUpper)+import           Data.Either+import           Data.Functor            (($>))+import           Data.List.Split         (splitOn)+import           Data.Ratio+import qualified Data.Set                as Set+import qualified Data.Text               as T++import           Text.Parsec+import           Text.Parsec.String+import qualified Text.Parsec.Token       as P++import           Language.Egison.AST+import           Language.Egison.Data++parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]+parseTopExprs = doParse $ do+  ret <- whiteSpace >> endBy topExpr whiteSpace+  eof+  return ret++parseTopExpr :: String -> Either EgisonError EgisonTopExpr+parseTopExpr = doParse $ do+  ret <- whiteSpace >> topExpr+  whiteSpace >> eof+  return ret++parseExprs :: String -> Either EgisonError [EgisonExpr]+parseExprs = doParse $ do+  ret <- whiteSpace >> endBy expr whiteSpace+  eof+  return ret++parseExpr :: String -> Either EgisonError EgisonExpr+parseExpr = doParse $ do+  ret <- whiteSpace >> expr+  whiteSpace >> eof+  return ret++--+-- 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 -> a+doParse' p input = case doParse p input of+                     Right x -> x++--+-- Expressions+--+topExpr :: Parser EgisonTopExpr+topExpr = try (Test <$> expr)+      <|> try defineExpr+      <|> try (parens (redefineExpr+                   <|> 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++testExpr :: Parser EgisonTopExpr+testExpr = keywordTest >> Test <$> expr++executeExpr :: Parser EgisonTopExpr+executeExpr = keywordExecute >> Execute <$> expr++loadFileExpr :: Parser EgisonTopExpr+loadFileExpr = keywordLoadFile >> LoadFile <$> stringLiteral++loadExpr :: Parser EgisonTopExpr+loadExpr = keywordLoad >> Load <$> stringLiteral++expr :: Parser EgisonExpr+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]+                                  parseindex = many1 (try (MultiSubscript   <$> (char '_' >> expr') <*> (string "..._" >> expr'))+                                                  <|> try (MultiSuperscript <$> (char '~' >> expr') <*> (string "...~" >> expr'))+                                                  <|> try (Subscript    <$> (char '_' >> expr'))+                                                  <|> try (Superscript  <$> (char '~' >> expr'))+                                                  <|> try (SupSubscript <$> (string "~_" >> expr'))+                                                  <|> try (Userscript   <$> (char '|' >> expr')))+++quoteExpr :: Parser EgisonExpr+quoteExpr = char '\'' >> QuoteExpr <$> expr'++expr' :: Parser EgisonExpr+expr' = try partialExpr+            <|> try constantExpr+            <|> try partialVarExpr+            <|> try freshVarExpr+            <|> try varExpr+            <|> inductiveDataExpr+            <|> try vectorExpr+            <|> try tupleExpr+            <|> try hashExpr+            <|> collectionExpr+            <|> quoteSymbolExpr+            <|> wedgeExpr+            <|> parens (ifExpr+                        <|> lambdaExpr+                        <|> memoizedLambdaExpr+                        <|> cambdaExpr+                        <|> procedureExpr+                        <|> patternFunctionExpr+                        <|> letRecExpr+                        <|> letExpr+                        <|> letStarExpr+                        <|> withSymbolsExpr+                        <|> doExpr+                        <|> ioExpr+                        <|> matchAllExpr+                        <|> matchAllDFSExpr+                        <|> matchExpr+                        <|> matchDFSExpr+                        <|> matchAllLambdaExpr+                        <|> matchLambdaExpr+                        <|> matcherExpr+                        <|> seqExpr+                        <|> applyExpr+                        <|> cApplyExpr+                        <|> algebraicDataMatcherExpr+                        <|> generateTensorExpr+                        <|> tensorExpr+                        <|> tensorContractExpr+                        <|> tensorMapExpr+                        <|> tensorMap2Expr+                        <|> transposeExpr+                        <|> subrefsExpr+                        <|> suprefsExpr+                        <|> userrefsExpr+                        <|> functionWithArgExpr+                        )+            <?> "expression"++varExpr :: Parser EgisonExpr+varExpr = VarExpr <$> identVarWithoutIndex++freshVarExpr :: Parser EgisonExpr+freshVarExpr = char '#' >> return FreshVarExpr++inductiveDataExpr :: Parser EgisonExpr+inductiveDataExpr = angles $ InductiveDataExpr <$> upperName <*> sepEndBy expr whiteSpace++tupleExpr :: Parser EgisonExpr+tupleExpr = brackets $ TupleExpr <$> sepEndBy expr whiteSpace++collectionExpr :: Parser EgisonExpr+collectionExpr = braces $ CollectionExpr <$> sepEndBy innerExpr whiteSpace+ where+  innerExpr :: Parser InnerExpr+  innerExpr = (char '@' >> SubCollectionExpr <$> expr)+               <|> ElementExpr <$> expr++vectorExpr :: Parser EgisonExpr+vectorExpr = between lp rp $ VectorExpr <$> sepEndBy expr whiteSpace+  where+    lp = P.lexeme lexer (string "[|")+    rp = string "|]"++hashExpr :: Parser EgisonExpr+hashExpr = between lp rp $ HashExpr <$> sepEndBy pairExpr whiteSpace+  where+    lp = P.lexeme lexer (string "{|")+    rp = string "|}"+    pairExpr :: Parser (EgisonExpr, EgisonExpr)+    pairExpr = brackets $ (,) <$> expr <*> expr++wedgeExpr :: Parser EgisonExpr+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)+  where+    lp = P.lexeme lexer (char '[')+    rp = char ']'++quoteSymbolExpr :: Parser EgisonExpr+quoteSymbolExpr = char '`' >> QuoteSymbolExpr <$> expr++matchAllExpr :: Parser EgisonExpr+matchAllExpr = keywordMatchAll >> MatchAllExpr BFSMode <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses)++matchAllDFSExpr :: Parser EgisonExpr+matchAllDFSExpr = keywordMatchAllDFS >> MatchAllExpr DFSMode <$> expr <*> expr <*> (((:[]) <$> matchClause) <|> matchClauses)++matchExpr :: Parser EgisonExpr+matchExpr = keywordMatch >> MatchExpr BFSMode <$> expr <*> expr <*> matchClauses++matchDFSExpr :: Parser EgisonExpr+matchDFSExpr = keywordMatchDFS >> MatchExpr DFSMode <$> expr <*> expr <*> matchClauses++matchAllLambdaExpr :: Parser EgisonExpr+matchAllLambdaExpr = keywordMatchAllLambda >> MatchAllLambdaExpr <$> expr <*> (((:[]) <$> matchClause) <|> matchClauses)++matchLambdaExpr :: Parser EgisonExpr+matchLambdaExpr = keywordMatchLambda >> MatchLambdaExpr <$> expr <*> matchClauses++matchClauses :: Parser [MatchClause]+matchClauses = braces $ sepEndBy matchClause whiteSpace++matchClause :: Parser MatchClause+matchClause = brackets $ (,) <$> pattern <*> expr++matcherExpr :: Parser EgisonExpr+matcherExpr = keywordMatcher >> MatcherExpr <$> ppMatchClauses++ppMatchClauses :: Parser [PatternDef]+ppMatchClauses = braces $ sepEndBy ppMatchClause whiteSpace++ppMatchClause :: Parser PatternDef+ppMatchClause = brackets $ (,,) <$> ppPattern <*> expr <*> pdMatchClauses++pdMatchClauses :: Parser [(PrimitiveDataPattern, EgisonExpr)]+pdMatchClauses = braces $ sepEndBy pdMatchClause whiteSpace++pdMatchClause :: Parser (PrimitiveDataPattern, EgisonExpr)+pdMatchClause = brackets $ (,) <$> pdPattern <*> expr++ppPattern :: Parser PrimitivePatPattern+ppPattern = P.lexeme lexer (ppWildCard+                        <|> ppPatVar+                        <|> ppValuePat+                        <|> ppInductivePat+                        <|> ppTuplePat+                        <?> "primitive-pattren-pattern")++ppWildCard :: Parser PrimitivePatPattern+ppWildCard = reservedOp "_" $> PPWildCard++ppPatVar :: Parser PrimitivePatPattern+ppPatVar = reservedOp "$" $> PPPatVar++ppValuePat :: Parser PrimitivePatPattern+ppValuePat = reservedOp ",$" >> PPValuePat <$> ident++ppInductivePat :: Parser PrimitivePatPattern+ppInductivePat = angles (PPInductivePat <$> lowerName <*> sepEndBy ppPattern whiteSpace)++ppTuplePat :: Parser PrimitivePatPattern+ppTuplePat = brackets $ PPTuplePat <$> sepEndBy ppPattern whiteSpace++pdPattern :: Parser PrimitiveDataPattern+pdPattern = P.lexeme lexer pdPattern'++pdPattern' :: Parser PrimitiveDataPattern+pdPattern' = reservedOp "_" $> PDWildCard+                    <|> (char '$' >> PDPatVar <$> ident)+                    <|> braces ((PDConsPat <$> pdPattern <*> (char '@' *> pdPattern))+                            <|> (PDSnocPat <$> (char '@' *> pdPattern) <*> pdPattern)+                            <|> pure PDEmptyPat)+                    <|> angles (PDInductivePat <$> upperName <*> sepEndBy pdPattern whiteSpace)+                    <|> brackets (PDTuplePat <$> sepEndBy pdPattern whiteSpace)+                    <|> PDConstantPat <$> constantExpr+                    <?> "primitive-data-pattern"++ifExpr :: Parser EgisonExpr+ifExpr = keywordIf >> IfExpr <$> expr <*> expr <*> expr++lambdaExpr :: Parser EgisonExpr+lambdaExpr = keywordLambda >> LambdaExpr <$> argNames <*> expr++memoizedLambdaExpr :: Parser EgisonExpr+memoizedLambdaExpr = keywordMemoizedLambda >> MemoizedLambdaExpr <$> varNames <*> expr++memoizeFrame :: Parser [(EgisonExpr, EgisonExpr, EgisonExpr)]+memoizeFrame = braces $ sepEndBy memoizeBinding whiteSpace++memoizeBinding :: Parser (EgisonExpr, EgisonExpr, EgisonExpr)+memoizeBinding = brackets $ (,,) <$> expr <*> expr <*> expr++cambdaExpr :: Parser EgisonExpr+cambdaExpr = keywordCambda >> char '$' >> CambdaExpr <$> ident <*> expr++procedureExpr :: Parser EgisonExpr+procedureExpr = keywordProcedure >> ProcedureExpr <$> varNames <*> expr++patternFunctionExpr :: Parser EgisonExpr+patternFunctionExpr = keywordPatternFunction >> PatternFunctionExpr <$> varNames <*> pattern++letRecExpr :: Parser EgisonExpr+letRecExpr =  keywordLetRec >> LetRecExpr <$> bindings <*> expr++letExpr :: Parser EgisonExpr+letExpr = keywordLet >> LetExpr <$> bindings <*> expr++letStarExpr :: Parser EgisonExpr+letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <*> expr++withSymbolsExpr :: Parser EgisonExpr+withSymbolsExpr = keywordWithSymbols >> WithSymbolsExpr <$> braces (sepEndBy ident whiteSpace) <*> expr++doExpr :: Parser EgisonExpr+doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (stringToVarExpr "return") (TupleExpr [])) expr++statements :: Parser [BindingExpr]+statements = braces $ sepEndBy statement whiteSpace++statement :: Parser BindingExpr+statement = try binding+        <|> try (brackets (([],) <$> expr))+        <|> (([],) <$> expr)++bindings :: Parser [BindingExpr]+bindings = braces $ sepEndBy binding whiteSpace++binding :: Parser BindingExpr+binding = brackets $ (,) <$> 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)++argNames :: Parser [Arg]+argNames = return <$> argName+            <|> brackets (sepEndBy argName whiteSpace)++argName :: Parser Arg+argName = try (ScalarArg <$> (char '$' >> ident))+      <|> try (InvertedScalarArg <$> (string "*$" >> ident))+      <|> try (TensorArg <$> (char '%' >> ident))++ioExpr :: Parser EgisonExpr+ioExpr = keywordIo >> IoExpr <$> expr++seqExpr :: Parser EgisonExpr+seqExpr = keywordSeq >> SeqExpr <$> expr <*> expr++cApplyExpr :: Parser EgisonExpr+cApplyExpr = keywordCApply >> CApplyExpr <$> expr <*> expr++applyExpr :: Parser EgisonExpr+applyExpr = do+  func <- expr+  args <- sepEndBy arg whiteSpace+  let vars = lefts args+  case vars of+    [] -> return . ApplyExpr func . TupleExpr $ rights args+    _ | all null vars ->+        let n = toInteger (length vars)+            args' = f args 1+         in return $ PartialExpr n $ ApplyExpr func (TupleExpr args')+      | all (not . null) vars ->+        let ns = Set.fromList $ map read vars+            n = Set.size ns+        in if Set.findMin ns == 1 && Set.findMax ns == n+             then+               let args' = map g args+                in return $ PartialExpr (toInteger n) $ ApplyExpr func (TupleExpr args')+             else fail "invalid partial application"+      | otherwise -> fail "invalid partial application"+ where+  arg = try (Right <$> expr)+         <|> char '$' *> (Left <$> option "" index)+  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit+  f [] _                   = []+  f (Left _ : args) n      = PartialVarExpr n : f args (n + 1)+  f (Right expr : args) n  = expr : f args n+  g (Left arg)   = PartialVarExpr (read arg)+  g (Right expr) = expr++partialExpr :: Parser EgisonExpr+partialExpr = (PartialExpr . read <$> index) <*> (char '#' >> expr)+ where+  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit++partialVarExpr :: Parser EgisonExpr+partialVarExpr = char '%' >> PartialVarExpr <$> integerLiteral++algebraicDataMatcherExpr :: Parser EgisonExpr+algebraicDataMatcherExpr = keywordAlgebraicDataMatcher+                                >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 inductivePat' whiteSpace)+  where+    inductivePat' :: Parser (String, [EgisonExpr])+    inductivePat' = angles $ (,) <$> lowerName <*> sepEndBy expr whiteSpace++generateTensorExpr :: Parser EgisonExpr+generateTensorExpr = keywordGenerateTensor >> GenerateTensorExpr <$> expr <*> expr++tensorExpr :: Parser EgisonExpr+tensorExpr = keywordTensor >> TensorExpr <$> expr <*> expr++tensorContractExpr :: Parser EgisonExpr+tensorContractExpr = keywordTensorContract >> TensorContractExpr <$> expr+--tensorContractExpr = keywordTensorContract >> TensorContractExpr <$> expr <*> expr++tensorMapExpr :: Parser EgisonExpr+tensorMapExpr = keywordTensorMap >> TensorMapExpr <$> expr <*> expr++tensorMap2Expr :: Parser EgisonExpr+tensorMap2Expr = keywordTensorMap2 >> TensorMap2Expr <$> expr <*> expr <*> expr++transposeExpr :: Parser EgisonExpr+transposeExpr = keywordTranspose >> TransposeExpr <$> expr <*> expr++subrefsExpr :: Parser EgisonExpr+subrefsExpr = (keywordSubrefs >> SubrefsExpr False <$> expr <*> expr)+               <|> (keywordSubrefsNew >> SubrefsExpr True <$> expr <*> expr)++suprefsExpr :: Parser EgisonExpr+suprefsExpr = (keywordSuprefs >> SuprefsExpr False <$> expr <*> expr)+               <|> (keywordSuprefsNew >> SuprefsExpr True <$> expr <*> expr)++userrefsExpr :: Parser EgisonExpr+userrefsExpr = (keywordUserrefs >> UserrefsExpr False <$> expr <*> expr)+                <|> (keywordUserrefsNew >> UserrefsExpr True <$> expr <*> expr)++-- Patterns++pattern :: Parser EgisonPattern+pattern = P.lexeme lexer (do pattern <- pattern'+                             option pattern $ IndexedPat pattern <$> many1 (try $ char '_' >> expr'))++pattern' :: Parser EgisonPattern+pattern' = wildCard+            <|> contPat+            <|> patVar+            <|> varPat+            <|> valuePat+            <|> predPat+            <|> notPat+            <|> tuplePat+            <|> inductivePat+            <|> laterPatVar+            <|> try seqNilPat+            <|> try seqConsPat+            <|> try seqPat+            <|> parens (andPat+                    <|> notPat'+                    <|> orPat+                    <|> loopPat+                    <|> letPat+                    <|> try divPat+                    <|> try plusPat+                    <|> try multPat+                    <|> try dApplyPat+                    <|> try pApplyPat+                    )++pattern'' :: Parser EgisonPattern+pattern'' = wildCard+            <|> patVar+            <|> valuePat++wildCard :: Parser EgisonPattern+wildCard = reservedOp "_" >> pure WildCard++patVar :: Parser EgisonPattern+patVar = char '$' >> PatVar <$> identVarWithoutIndex++varPat :: Parser EgisonPattern+varPat = VarPat <$> ident++valuePat :: Parser EgisonPattern+valuePat = char ',' >> ValuePat <$> expr++predPat :: Parser EgisonPattern+predPat = char '?' >> PredPat <$> expr++letPat :: Parser EgisonPattern+letPat = keywordLet >> LetPat <$> bindings <*> pattern++notPat :: Parser EgisonPattern+notPat = char '!' >> NotPat <$> pattern++notPat' :: Parser EgisonPattern+notPat' = keywordNot >> NotPat <$> pattern++tuplePat :: Parser EgisonPattern+tuplePat = brackets $ TuplePat <$> sepEndBy pattern whiteSpace++inductivePat :: Parser EgisonPattern+inductivePat = angles $ InductivePat <$> lowerName <*> sepEndBy pattern whiteSpace++contPat :: Parser EgisonPattern+contPat = keywordCont >> pure ContPat++andPat :: Parser EgisonPattern+andPat = (reservedOp "&" <|> keywordAnd) >> AndPat <$> sepEndBy pattern whiteSpace++orPat :: Parser EgisonPattern+orPat = (reservedOp "|" <|> keywordOr) >> OrPat <$> sepEndBy pattern whiteSpace++pApplyPat :: Parser EgisonPattern+pApplyPat = PApplyPat <$> expr <*> sepEndBy pattern whiteSpace++dApplyPat :: Parser EgisonPattern+dApplyPat = DApplyPat <$> pattern'' <*> sepEndBy pattern whiteSpace++loopPat :: Parser EgisonPattern+loopPat = keywordLoop >> char '$' >> LoopPat <$> identVarWithoutIndex <*> 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)))++seqNilPat :: Parser EgisonPattern+seqNilPat = braces $ pure SeqNilPat++seqConsPat :: Parser EgisonPattern+seqConsPat = braces $ SeqConsPat <$> pattern <*> (char '@' >> pattern)++seqPat :: Parser EgisonPattern+seqPat = braces $ do+  pats <- sepEndBy pattern whiteSpace+  tailPat <- option SeqNilPat (char '@' >> pattern)+  return $ foldr SeqConsPat tailPat pats++laterPatVar :: Parser EgisonPattern+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+                 <|> (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+  char '.'+  mStr <- many1 digit+  let m = read mStr+  let l = m % (10 ^ fromIntegral (length mStr))+  if n < 0 then return (fromRational (fromIntegral n - l) :: Double)+           else return (fromRational (fromIntegral n + l) :: Double)++--+-- Tokens+--++egisonDef :: P.GenLanguageDef String () Identity+egisonDef =+  P.LanguageDef { P.commentStart       = "#|"+                , P.commentEnd         = "|#"+                , P.commentLine        = ";"+                , P.identStart         = letter <|> symbol1 <|> symbol0+                , P.identLetter        = letter <|> digit <|> symbol2+                , P.opStart            = symbol1+                , P.opLetter           = symbol1+                , P.reservedNames      = reservedKeywords+                , P.reservedOpNames    = reservedOperators+                , P.nestedComments     = True+                , P.caseSensitive      = True }++symbol0 = char '^'+-- Don't allow three consecutive dots to be a part of identifier+symbol1 = oneOf "+-*/=∂∇" <|> try (char '.' <* notFollowedBy (string ".."))+symbol2 = symbol1 <|> oneOf "'!?₀₁₂₃₄₅₆₇₈₉"++lexer :: P.GenTokenParser String () Identity+lexer = P.makeTokenParser egisonDef++reservedKeywords :: [String]+reservedKeywords =+  [ "define"+  , "redefine"+  , "set!"+  , "test"+  , "execute"+  , "load-file"+  , "load"+  , "if"+  , "seq"+  , "capply"+  , "lambda"+  , "memoized-lambda"+  , "memoize"+  , "cambda"+  , "procedure"+  , "pattern-function"+  , "letrec"+  , "let"+  , "let*"+  , "with-symbols"+--  , "not"+--  , "and"+--  , "or"+  , "loop"+  , "match-all"+  , "match"+  , "match-all-dfs"+  , "match-dfs"+  , "match-all-lambda"+  , "match-lambda"+  , "matcher"+  , "do"+  , "io"+  , "algebraic-data-matcher"+  , "generate-tensor"+  , "tensor"+  , "contract"+  , "tensor-map"+  , "tensor-map2"+  , "transpose"+  , "subrefs"+  , "subrefs!"+  , "suprefs"+  , "suprefs!"+  , "user-refs"+  , "user-refs!"+  , "function"+  , "something"+  , "undefined"]++reservedOperators :: [String]+reservedOperators =+  [ "$"+  , ",$"+  , "_"+  , "^"+  , "&"+  , "|*"+--  , "'"+--  , "~"+--  , "!"+--  , ","+--  , "@"+  , "..."]++reserved :: String -> Parser ()+reserved = P.reserved lexer++reservedOp :: String -> Parser ()+reservedOp = P.reservedOp lexer++keywordDefine               = reserved "define"+keywordRedefine             = reserved "redefine"+keywordSet                  = reserved "set!"+keywordTest                 = reserved "test"+keywordExecute              = reserved "execute"+keywordLoadFile             = reserved "load-file"+keywordLoad                 = reserved "load"+keywordIf                   = reserved "if"+keywordNot                  = reserved "not"+keywordAnd                  = reserved "and"+keywordOr                   = reserved "or"+keywordSeq                  = reserved "seq"+keywordCApply               = reserved "capply"+keywordLambda               = reserved "lambda"+keywordMemoizedLambda       = reserved "memoized-lambda"+keywordMemoize              = reserved "memoize"+keywordCambda               = reserved "cambda"+keywordProcedure            = reserved "procedure"+keywordPatternFunction      = reserved "pattern-function"+keywordLetRec               = reserved "letrec"+keywordLet                  = reserved "let"+keywordLetStar              = reserved "let*"+keywordWithSymbols          = reserved "with-symbols"+keywordLoop                 = reserved "loop"+keywordCont                 = reserved "..."+keywordMatchAll             = reserved "match-all"+keywordMatchAllDFS          = reserved "match-all-dfs"+keywordMatchAllLambda       = reserved "match-all-lambda"+keywordMatch                = reserved "match"+keywordMatchDFS             = reserved "match-dfs"+keywordMatchLambda          = reserved "match-lambda"+keywordMatcher              = reserved "matcher"+keywordDo                   = reserved "do"+keywordIo                   = reserved "io"+keywordSomething            = reserved "something"+keywordUndefined            = reserved "undefined"+keywordAlgebraicDataMatcher = reserved "algebraic-data-matcher"+keywordGenerateTensor       = reserved "generate-tensor"+keywordTensor               = reserved "tensor"+keywordTensorContract       = reserved "contract"+keywordTensorMap            = reserved "tensor-map"+keywordTensorMap2           = reserved "tensor-map2"+keywordTranspose            = reserved "transpose"+keywordSubrefs              = reserved "subrefs"+keywordSubrefsNew           = reserved "subrefs!"+keywordSuprefs              = reserved "suprefs"+keywordSuprefsNew           = reserved "suprefs!"+keywordUserrefs             = reserved "user-refs"+keywordUserrefsNew          = reserved "user-refs!"+keywordFunction             = reserved "function"++sign :: Num a => Parser (a -> a)+sign = (char '-' >> return negate)+   <|> (char '+' >> return id)+   <|> return id++integerLiteral :: Parser Integer+integerLiteral = sign <*> P.natural lexer++stringLiteral :: Parser String+stringLiteral = P.stringLiteral lexer++charLiteral :: Parser Char+charLiteral = P.charLiteral lexer++oneChar :: Parser Char+oneChar = do+  string "c#"+  x <- (char '\\' >> anyChar >>= (\x -> return ['\\', x])) <|> (anyChar >>= (\x -> return [x]))+  return $ doParse' charLiteral $ "'" ++ x ++ "'"++boolLiteral :: Parser Bool+boolLiteral = char '#' >> (char 't' $> True <|> char 'f' $> False)++whiteSpace :: Parser ()+whiteSpace = P.whiteSpace lexer++parens :: Parser a -> Parser a+parens = P.parens lexer++brackets :: Parser a -> Parser a+brackets = P.brackets lexer++braces :: Parser a -> Parser a+braces = P.braces lexer++angles :: Parser a -> Parser a+angles = P.angles lexer++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)++indexForVar :: Parser (Index String)+indexForVar = try (char '~' >> Superscript <$> ident)+        <|> try (char '_' >> Subscript <$> ident)++indexType :: Parser (Index ())+indexType = try (char '~' >> return (Superscript ()))+        <|> try (char '_' >> return (Subscript ()))++upperName :: Parser String+upperName = P.lexeme lexer upperName'++upperName' :: Parser String+upperName' = (:) <$> upper <*> option "" ident+ where+  upper :: Parser Char+  upper = satisfy isUpper++lowerName :: Parser String+lowerName = P.lexeme lexer lowerName'++lowerName' :: Parser String+lowerName' = (:) <$> lower <*> option "" ident+ where+  lower :: Parser Char+  lower = satisfy isLower++-- Translate identifiers for Non-S syntax+toCamelCase :: String -> String+toCamelCase "-'" = "-'"+toCamelCase "f.-'" = "f.-'"+toCamelCase "b.." = "b."+toCamelCase "b..'" = "b.'"+toCamelCase x =+  let heads:tails = splitOn "-" x+   in concat $ heads : map capitalize tails+  where+    capitalize [] = "-"+    capitalize (x:xs) = toUpper x : xs
− hs-src/Language/Egison/ParserNonS.hs 
@@ -1,992 +0,0 @@-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE NamedFieldPuns   #-}--{- |-Module      : Language.Egison.ParserNonS-Licence     : MIT--This module provides the new parser of Egison.--}--module Language.Egison.ParserNonS-       (-       -- * Parse a string-         readTopExprs-       , readTopExpr-       , readExprs-       , readExpr-       , parseTopExprs-       , parseTopExpr-       , parseExprs-       , parseExpr-       -- * Parse a file-       , loadLibraryFile-       , loadFile-       ) where--import           Control.Applicative            (pure, (*>), (<$>), (<$), (<*), (<*>))-import           Control.Monad.Except           (liftIO, throwError)-import           Control.Monad.State            (evalStateT, get, put, StateT, unless)--import           Data.Char                      (isAsciiUpper, isLetter)-import           Data.Either                    (isRight)-import           Data.Functor                   (($>))-import           Data.List                      (find, groupBy, insertBy)-import           Data.Maybe                     (fromJust, isJust, isNothing)-import           Data.Text                      (pack)--import           Control.Monad.Combinators.Expr-import           Text.Megaparsec-import           Text.Megaparsec.Char-import qualified Text.Megaparsec.Char.Lexer     as L--- import           Text.Megaparsec.Debug          (dbg)-import           Text.Megaparsec.Pos            (Pos)-import           System.Directory               (doesFileExist, getHomeDirectory)-import           System.IO--import           Language.Egison.AST-import           Language.Egison.Desugar-import           Language.Egison.Data-import           Paths_egison                   (getDataFileName)--readTopExprs :: String -> EgisonM [EgisonTopExpr]-readTopExprs = either throwError (mapM desugarTopExpr) . parseTopExprs---- TODO(momohatt): Parse from the last state-readTopExpr :: String -> EgisonM EgisonTopExpr-readTopExpr = either throwError desugarTopExpr . parseTopExpr--readExprs :: String -> EgisonM [EgisonExpr]-readExprs = either throwError (mapM desugarExpr) . parseExprs--readExpr :: String -> EgisonM EgisonExpr-readExpr = either throwError desugarExpr . parseExpr--parseTopExprs :: String -> Either EgisonError [EgisonTopExpr]-parseTopExprs = doParse $ many (L.nonIndented sc topExpr) <* eof--parseTopExpr :: String -> Either EgisonError EgisonTopExpr-parseTopExpr = doParse $ sc >> topExpr <* eof--parseExprs :: String -> Either EgisonError [EgisonExpr]-parseExprs = doParse $ many (L.nonIndented sc expr) <* eof--parseExpr :: String -> Either EgisonError EgisonExpr-parseExpr = doParse $ sc >> expr <* eof---- |Load a libary file-loadLibraryFile :: FilePath -> EgisonM [EgisonTopExpr]-loadLibraryFile file = do-  homeDir <- liftIO getHomeDirectory-  doesExist <- liftIO $ doesFileExist $ homeDir ++ "/.egison/" ++ file-  if doesExist-    then loadFile $ homeDir ++ "/.egison/" ++ file-    else liftIO (getDataFileName file) >>= loadFile---- |Load a file-loadFile :: FilePath -> EgisonM [EgisonTopExpr]-loadFile file = do-  doesExist <- liftIO $ doesFileExist file-  unless doesExist $ throwError $ Default ("file does not exist: " ++ file)-  input <- liftIO $ readUTF8File file-  exprs <- readTopExprs $ shebang input-  concat <$> mapM recursiveLoad exprs- where-  recursiveLoad (Load file)     = loadLibraryFile file-  recursiveLoad (LoadFile file) = loadFile file-  recursiveLoad expr            = return [expr]-  shebang :: String -> String-  shebang ('#':'!':cs) = ';':'#':'!':cs-  shebang cs           = cs--readUTF8File :: FilePath -> IO String-readUTF8File name = do-  h <- openFile name ReadMode-  hSetEncoding h utf8-  hGetContents h------- 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-                       }--data CustomError-  = IllFormedSection Infix Infix-  | IllFormedDefine-  deriving (Eq, Ord)--instance ShowErrorComponent CustomError where-  showErrorComponent (IllFormedSection op op') =-    "The operator " ++ info op ++ " must have lower precedence than " ++ info op'-    where-      info op =-         "'" ++ repr op ++ "' [" ++ show (assoc op) ++ " " ++ show (priority op) ++ "]"-  showErrorComponent IllFormedDefine =-    "Failed to parse the left hand side of definition 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------- Expressions-----topExpr :: Parser EgisonTopExpr-topExpr = Load     <$> (reserved "load" >> stringLiteral)-      <|> LoadFile <$> (reserved "loadFile" >> stringLiteral)-      <|> infixExpr-      <|> defineOrTestExpr-      <?> "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-  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) }--infixExpr :: Parser EgisonTopExpr-infixExpr = do-  assoc     <- (reserved "infixl" $> LeftAssoc)-           <|> (reserved "infixr" $> RightAssoc)-           <|> (reserved "infix"  $> NonAssoc)-  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 }-  addNewOp newop isPattern-  return (InfixDecl isPattern newop)-  where-    check :: String -> Parser String-    check ('!':_) = fail $ "cannot declare infix starting with '!'"-    check x | x `elem` reservedOp = fail $ show x ++ " cannot be a new infix"-            | otherwise           = return x--    -- Checks if given string is valid for pattern op.-    checkP :: String -> Parser String-    checkP x | x `elem` reservedPOp = fail $ show x ++ " cannot be a new pattern infix"-             | otherwise           = return x--    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 (ApplyExpr (VarExpr var) (TupleExpr args)) = do-      args' <- mapM ((ScalarArg <$>) . exprToStr) args-      return $ Function var args'-    convertToDefine (ApplyExpr (SectionExpr op Nothing Nothing) (TupleExpr [x, y])) = do-      args <- mapM ((ScalarArg <$>) . exprToStr) [x, y]-      return $ Function (stringToVar (repr op)) args-    convertToDefine e@(BinaryOpExpr op _ _)-      | repr op == "*" || repr op == "%" || repr op == "$" = do-        args <- exprToArgs e-        case args of-          ScalarArg var : args -> return $ Function (Var [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 (Var [x] [])) = Just x-    exprToStr _                      = Nothing--    exprToArgs :: EgisonExpr -> Maybe [Arg]-    exprToArgs (VarExpr (Var [x] [])) = return [ScalarArg x]-    exprToArgs (ApplyExpr func (TupleExpr args)) =-      (++) <$> exprToArgs func <*> mapM ((ScalarArg <$>) . exprToStr) args-    exprToArgs (SectionExpr op Nothing Nothing) = return [ScalarArg (repr op)]-    exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "*" = do-      lhs' <- exprToArgs lhs-      rhs' <- exprToArgs rhs-      case rhs' of-        ScalarArg x : xs -> return (lhs' ++ InvertedScalarArg x : xs)-        _                -> Nothing-    exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "%" = do-      lhs' <- exprToArgs lhs-      rhs' <- exprToArgs rhs-      case rhs' of-        ScalarArg x : xs -> return (lhs' ++ TensorArg x : xs)-        _                -> Nothing-    exprToArgs (BinaryOpExpr op lhs rhs) | repr op == "$" = do-      lhs' <- exprToArgs lhs-      rhs' <- exprToArgs rhs-      case rhs' of-        ScalarArg _ : _ -> return (lhs' ++ rhs')-        _               -> Nothing-    exprToArgs _ = Nothing--expr :: Parser EgisonExpr-expr = do-  body <- exprWithoutWhere-  bindings <- optional (reserved "where" >> alignSome binding)-  return $ case bindings of-             Nothing -> body-             Just bindings -> LetRecExpr bindings body--exprWithoutWhere :: Parser EgisonExpr-exprWithoutWhere =-       ifExpr-   <|> patternMatchExpr-   <|> lambdaExpr-   <|> lambdaLikeExpr-   <|> letExpr-   <|> withSymbolsExpr-   <|> doExpr-   <|> ioExpr-   <|> capplyExpr-   <|> matcherExpr-   <|> algebraicDataMatcherExpr-   <|> arrayOpExpr-   <|> tensorExpr-   <|> tensorOpExpr-   <|> functionExpr-   <|> refsExpr-   <|> opExpr-   <?> "expression"---- Also parses atomExpr-opExpr :: Parser EgisonExpr-opExpr = do-  infixes <- exprInfix <$> get-  makeExprParser atomOrApplyExpr (makeExprTable infixes)--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'-  where-    -- notFollowedBy (in unary and binary) is necessary for section expression.-    unary :: String -> Parser (EgisonExpr -> EgisonExpr)-    unary sym = UnaryOpExpr <$> try (operator sym <* notFollowedBy (symbol ")"))--    binary :: Infix -> Parser (EgisonExpr -> EgisonExpr -> EgisonExpr)-    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 $ BinaryOpExpr op--    toOperator :: Infix -> Operator Parser EgisonExpr-    toOperator = infixToOperator binary---ifExpr :: Parser EgisonExpr-ifExpr = reserved "if" >> IfExpr <$> expr <* reserved "then" <*> expr <* reserved "else" <*> expr--patternMatchExpr :: Parser EgisonExpr-patternMatchExpr = makeMatchExpr (reserved "match")       (MatchExpr BFSMode)-               <|> makeMatchExpr (reserved "matchDFS")    (MatchExpr DFSMode)-               <|> makeMatchExpr (reserved "matchAll")    (MatchAllExpr BFSMode)-               <|> makeMatchExpr (reserved "matchAllDFS") (MatchAllExpr DFSMode)-               <?> "pattern match expression"-  where-    makeMatchExpr keyword ctor = ctor <$> (keyword >> expr)-                                      <*> (reserved "as" >> expr)-                                      <*> (reserved "with" >> matchClauses1)---- Parse more than 1 match clauses.-matchClauses1 :: Parser [MatchClause]-matchClauses1 =-  -- If the first bar '|' is missing, then it is expected to have only one match clause.-  (lookAhead (symbol "|") >> alignSome matchClause) <|> (:[]) <$> matchClauseWithoutBar-  where-    matchClauseWithoutBar :: Parser MatchClause-    matchClauseWithoutBar = (,) <$> pattern <*> (symbol "->" >> expr)--    matchClause :: Parser MatchClause-    matchClause = (,) <$> (symbol "|" >> pattern) <*> (symbol "->" >> expr)--lambdaExpr :: Parser EgisonExpr-lambdaExpr = symbol "\\" >> (-      makeMatchLambdaExpr (reserved "match")    MatchLambdaExpr-  <|> makeMatchLambdaExpr (reserved "matchAll") MatchAllLambdaExpr-  <|> try (LambdaExpr <$> some arg <* symbol "->") <*> expr-  <|> PatternFunctionExpr <$> some lowerId <*> (symbol "=>" >> pattern))-  <?> "lambda or pattern function expression"-  where-    makeMatchLambdaExpr keyword ctor = do-      matcher <- keyword >> reserved "as" >> expr-      clauses <- reserved "with" >> matchClauses1-      return $ ctor matcher clauses--lambdaLikeExpr :: Parser EgisonExpr-lambdaLikeExpr =-        (reserved "memoizedLambda" >> MemoizedLambdaExpr <$> many lowerId <*> (symbol "->" >> expr))-    <|> (reserved "procedure"      >> ProcedureExpr      <$> many lowerId <*> (symbol "->" >> expr))-    <|> (reserved "cambda"         >> CambdaExpr         <$> lowerId      <*> (symbol "->" >> expr))--arg :: Parser Arg-arg = InvertedScalarArg <$> (char '*' >> ident)-  <|> TensorArg         <$> (char '%' >> ident)-  <|> ScalarArg         <$> (char '$' >> ident)-  <|> ScalarArg         <$> ident-  <?> "argument"--letExpr :: Parser EgisonExpr-letExpr = do-  binds <- reserved "let" >> oneLiner <|> alignSome binding-  body  <- reserved "in" >> expr-  return $ LetRecExpr binds body-  where-    oneLiner :: Parser [BindingExpr]-    oneLiner = braces $ sepBy binding (symbol ";")--binding :: Parser BindingExpr-binding = do-  (vars, args) <- (,[]) <$> parens (sepBy varLiteral comma)-              <|> do var <- varLiteral-                     args <- many arg-                     return ([var], args)-  body <- symbol ":=" >> expr-  return $ case args of-             [] -> (vars, body)-             _  -> (vars, LambdaExpr args body)--withSymbolsExpr :: Parser EgisonExpr-withSymbolsExpr = WithSymbolsExpr <$> (reserved "withSymbols" >> brackets (sepBy ident comma)) <*> expr--doExpr :: Parser EgisonExpr-doExpr = do-  stmts <- reserved "do" >> oneLiner <|> alignSome statement-  return $ case last stmts of-             ([], retExpr@(ApplyExpr (VarExpr (Var ["return"] _)) _)) ->-               DoExpr (init stmts) retExpr-             _ -> DoExpr stmts (makeApply' "return" [])-  where-    statement :: Parser BindingExpr-    statement = (reserved "let" >> binding) <|> ([],) <$> expr--    oneLiner :: Parser [BindingExpr]-    oneLiner = braces $ sepBy statement (symbol ";")--ioExpr :: Parser EgisonExpr-ioExpr = IoExpr <$> (reserved "io" >> expr)--capplyExpr :: Parser EgisonExpr-capplyExpr = CApplyExpr <$> (reserved "capply" >> atomExpr) <*> atomExpr--matcherExpr :: Parser EgisonExpr-matcherExpr = do-  reserved "matcher"-  -- Assuming it is unlikely that users want to write matchers with only 1-  -- pattern definition, the first '|' (bar) is made indispensable in matcher-  -- expression.-  MatcherExpr <$> alignSome (symbol "|" >> patternDef)-  where-    patternDef :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])-    patternDef = do-      pp <- ppPattern-      returnMatcher <- reserved "as" >> expr <* reserved "with"-      datapat <- alignSome (symbol "|" >> dataCases)-      return (pp, returnMatcher, datapat)--    dataCases :: Parser (PrimitiveDataPattern, EgisonExpr)-    dataCases = (,) <$> pdPattern <*> (symbol "->" >> expr)--algebraicDataMatcherExpr :: Parser EgisonExpr-algebraicDataMatcherExpr = do-  reserved "algebraicDataMatcher"-  AlgebraicDataMatcherExpr <$> alignSome (symbol "|" >> patternDef)-  where-    patternDef = indentBlock lowerId atomExpr--arrayOpExpr :: Parser EgisonExpr-arrayOpExpr =-      (reserved "generateArray" >> GenerateArrayExpr <$> atomExpr <*> arrayShape)-  <|> (reserved "arrayBounds"   >> ArrayBoundsExpr   <$> atomExpr)-  <|> (reserved "arrayRef"      >> ArrayRefExpr      <$> atomExpr <*> atomExpr)-    where-      arrayShape :: Parser (EgisonExpr, EgisonExpr)-      arrayShape = parens $ (,) <$> expr <*> (comma >> expr)--tensorExpr :: Parser EgisonExpr-tensorExpr = TensorExpr <$> (reserved "tensor" >> atomExpr) <*> atomExpr--tensorOpExpr :: Parser EgisonExpr-tensorOpExpr =-      (reserved "generateTensor" >> GenerateTensorExpr <$> atomExpr <*> atomExpr)-  <|> (reserved "contract"       >> TensorContractExpr <$> atomExpr <*> atomExpr)-  <|> (reserved "tensorMap"      >> TensorMapExpr      <$> atomExpr <*> atomExpr)-  <|> (reserved "tensorMap2"     >> TensorMap2Expr     <$> atomExpr <*> atomExpr <*> atomExpr)-  <|> (reserved "transpose"      >> TransposeExpr      <$> atomExpr <*> atomExpr)--functionExpr :: Parser EgisonExpr-functionExpr = FunctionExpr <$> (reserved "function" >> parens (sepBy expr comma))--refsExpr :: Parser EgisonExpr-refsExpr =-      (reserved "subrefs"   >> SubrefsExpr  False <$> atomExpr <*> atomExpr)-  <|> (reserved "subrefs!"  >> SubrefsExpr  True  <$> atomExpr <*> atomExpr)-  <|> (reserved "suprefs"   >> SuprefsExpr  False <$> atomExpr <*> atomExpr)-  <|> (reserved "suprefs!"  >> SuprefsExpr  True  <$> atomExpr <*> atomExpr)-  <|> (reserved "userRefs"  >> UserrefsExpr False <$> atomExpr <*> atomExpr)-  <|> (reserved "userRefs!" >> UserrefsExpr True  <$> atomExpr <*> atomExpr)--collectionExpr :: Parser EgisonExpr-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]--    elementsExpr = CollectionExpr <$> (sepBy (ElementExpr <$> 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 = 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]-    -- 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 = do-      infixes <- exprInfix <$> get-      op      <- choice $ map (infixLiteral . repr) infixes-      rarg    <- optional expr-      case rarg of-        Just (BinaryOpExpr op' _ _)-          | assoc op' /= RightAssoc && 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 = do-      infixes <- exprInfix <$> get-      larg    <- opExpr-      op      <- choice $ map (infixLiteral . repr) infixes-      case larg of-        BinaryOpExpr op' _ _-          | assoc op' /= LeftAssoc && priority op >= priority op' ->-          customFailure (IllFormedSection op op')-        _ -> return (SectionExpr op (Just larg) Nothing)--arrayExpr :: Parser EgisonExpr-arrayExpr = ArrayExpr <$> between (symbol "(|") (symbol "|)") (sepEndBy expr comma)--vectorExpr :: Parser EgisonExpr-vectorExpr = VectorExpr <$> between (symbol "[|") (symbol "|]") (sepEndBy expr comma)--hashExpr :: Parser EgisonExpr-hashExpr = HashExpr <$> hashBraces (sepEndBy hashElem comma)-  where-    hashBraces = between (symbol "{|") (symbol "|}")-    hashElem = parens $ (,) <$> expr <*> (comma >> expr)--index :: Parser (Index EgisonExpr)-index = SupSubscript <$> (string "~_" >> atomExpr')-    <|> try (char '_' >> subscript)-    <|> try (char '~' >> superscript)-    <|> try (Userscript <$> (char '|' >> atomExpr'))-    <?> "index"-  where-    subscript = do-      e1 <- atomExpr'-      e2 <- optional (string "..._" >> atomExpr')-      case e2 of-        Nothing  -> return $ Subscript e1-        Just e2' -> return $ MultiSubscript e1 e2'-    superscript = do-      e1 <- atomExpr'-      e2 <- optional (string "...~" >> atomExpr')-      case e2 of-        Nothing  -> return $ Superscript e1-        Just e2' -> return $ MultiSuperscript e1 e2'--atomOrApplyExpr :: Parser EgisonExpr-atomOrApplyExpr = do-  (func, args) <- indentBlock atomExpr atomExpr-  return $ case args of-             [] -> func-             _  -> makeApply func args---- (Possibly indexed) atomic expressions-atomExpr :: Parser EgisonExpr-atomExpr = do-  e <- atomExpr'-  override <- isNothing <$> optional (try (string "..." <* lookAhead index))-  indices <- many index-  return $ case indices of-             [] -> e-             _  -> IndexedExpr override e indices---- Atomic expressions without index-atomExpr' :: Parser EgisonExpr-atomExpr' = partialExpr    -- must come before |constantExpr|-        <|> constantExpr-        <|> FreshVarExpr <$ symbol "#"-        <|> VarExpr <$> varLiteral-        <|> vectorExpr     -- must come before |collectionExpr|-        <|> arrayExpr      -- must come before |tupleOrParenExpr|-        <|> collectionExpr-        <|> tupleOrParenExpr-        <|> hashExpr-        <|> QuoteExpr <$> (char '\'' >> atomExpr') -- must come after |constantExpr|-        <|> QuoteSymbolExpr <$> (char '`' >> atomExpr')-        <|> PartialVarExpr  <$> try (char '%' >> positiveIntegerLiteral)-        <?> "atomic expression"--partialExpr :: Parser EgisonExpr-partialExpr = do-  n    <- try (L.decimal <* char '#') -- No space after the index-  body <- atomExpr                    -- No space after '#'-  return $ PartialExpr n body--constantExpr :: Parser EgisonExpr-constantExpr = numericExpr-           <|> BoolExpr <$> boolLiteral-           <|> CharExpr <$> try charLiteral        -- try for quoteExpr-           <|> StringExpr . pack <$> stringLiteral-           <|> SomethingExpr <$ reserved "something"-           <|> UndefinedExpr <$ reserved "undefined"--numericExpr :: Parser EgisonExpr-numericExpr = FloatExpr <$> try positiveFloatLiteral-          <|> IntegerExpr <$> positiveIntegerLiteral-          <?> "numeric expression"------ Pattern-----pattern :: Parser EgisonPattern-pattern = letPattern-      <|> forallPattern-      <|> loopPattern-      <|> opPattern-      <?> "pattern"--letPattern :: Parser EgisonPattern-letPattern =-  reserved "let" >> LetPat <$> alignSome binding <*> (reserved "in" >> pattern)--forallPattern :: Parser EgisonPattern-forallPattern =-  reserved "forall" >> ForallPat <$> atomPattern <*> atomPattern--loopPattern :: Parser EgisonPattern-loopPattern =-  LoopPat <$> (reserved "loop" >> patVarLiteral) <*> loopRange-          <*> atomPattern <*> atomPattern-  where-    loopRange :: Parser LoopRange-    loopRange =-      parens $ do start <- expr-                  ends  <- option (defaultEnds start) (try $ comma >> expr)-                  as    <- option WildCard (comma >> pattern)-                  return $ LoopRange start ends as--    defaultEnds s =-      ApplyExpr (stringToVarExpr "from")-                (makeApply (stringToVarExpr "-'") [s, IntegerExpr 1])--seqPattern :: Parser EgisonPattern-seqPattern = do-  pats <- braces $ sepBy pattern comma-  return $ foldr SeqConsPat SeqNilPat pats--opPattern :: Parser EgisonPattern-opPattern = do-  ops <- patternInfix <$> get-  makeExprParser applyOrAtomPattern (makePatternTable ops)--makePatternTable :: [Infix] -> [[Operator Parser EgisonPattern]]-makePatternTable ops =-  let infixes = map toOperator ops-   in map (map snd) (groupBy (\x y -> fst x == fst y) infixes)-  where-    toOperator :: Infix -> (Int, Operator Parser EgisonPattern)-    toOperator op = (priority op, infixToOperator binary op)--    binary :: Infix -> Parser (EgisonPattern -> EgisonPattern -> EgisonPattern)-    binary op = do-      op <- try (indented >> patInfixLiteral (repr op))-      return $ InfixPat op--applyOrAtomPattern :: Parser EgisonPattern-applyOrAtomPattern = (do-    (func, args) <- indentBlock (try atomPattern) atomPattern-    case (func, args) of-      (_,                 []) -> return func-      (InductivePat x [], _)  -> return $ InductiveOrPApplyPat x args-      _                       -> fail $ "Pattern not understood: " ++ show (func, args))-  <|> (do-    (func, args) <- indentBlock atomExpr atomPattern-    return $ PApplyPat func args)---- (Possibly indexed) atomic pattern-atomPattern :: Parser EgisonPattern-atomPattern = do-  pat     <- atomPattern'-  indices <- many . try $ char '_' >> atomExpr'-  return $ case indices of-             [] -> pat-             _  -> IndexedPat pat indices---- Atomic pattern without index-atomPattern' :: Parser EgisonPattern-atomPattern' = WildCard <$  symbol "_"-           <|> PatVar   <$> patVarLiteral-           <|> NotPat   <$> (symbol "!" >> atomPattern)-           <|> ValuePat <$> (char '#' >> atomExpr)-           <|> InductivePat "nil" [] <$ (symbol "[" >> symbol "]")-           <|> InductivePat <$> lowerId <*> pure []-           <|> VarPat   <$> (char '~' >> lowerId)-           <|> PredPat  <$> (symbol "?" >> atomExpr)-           <|> ContPat  <$ symbol "..."-           <|> makeTupleOrParen pattern TuplePat-           <|> seqPattern-           <|> LaterPatVar <$ symbol "@"-           <?> "atomic pattern"--ppPattern :: Parser PrimitivePatPattern-ppPattern = PPInductivePat <$> lowerId <*> many ppAtom-        <|> do ops <- patternInfix <$> get-               makeExprParser ppAtom (makeTable ops)-        <?> "primitive pattern pattern"-  where-    makeTable :: [Infix] -> [[Operator Parser PrimitivePatPattern]]-    makeTable ops =-      map (map toOperator) (groupBy (\x y -> priority x == priority y) ops)--    toOperator :: Infix -> Operator Parser PrimitivePatPattern-    toOperator = infixToOperator inductive2--    inductive2 op = (\x y -> PPInductivePat (func op) [x, y]) <$ operator (repr op)--    ppAtom :: Parser PrimitivePatPattern-    ppAtom = PPWildCard <$ symbol "_"-         <|> PPPatVar   <$ symbol "$"-         <|> PPValuePat <$> (string "#$" >> lowerId)-         <|> PPInductivePat "nil" [] <$ (symbol "[" >> symbol "]")-         <|> makeTupleOrParen ppPattern PPTuplePat--pdPattern :: Parser PrimitiveDataPattern-pdPattern = PDInductivePat <$> upperId <*> many pdAtom-        <|> PDSnocPat <$> (symbol "snoc" >> pdAtom) <*> pdAtom-        <|> makeExprParser pdAtom table-        <?> "primitive data pattern"-  where-    table :: [[Operator Parser PrimitiveDataPattern]]-    table =-      [ [ InfixR (PDConsPat <$ symbol "::") ]-      ]-    pdAtom :: Parser PrimitiveDataPattern-    pdAtom = PDWildCard    <$ symbol "_"-         <|> PDPatVar      <$> (char '$' >> lowerId)-         <|> PDConstantPat <$> constantExpr-         <|> PDEmptyPat    <$ (symbol "[" >> symbol "]")-         <|> makeTupleOrParen pdPattern PDTuplePat------- Tokens------- Space Comsumer-sc :: Parser ()-sc = L.space space1 lineCmnt blockCmnt-  where-    lineCmnt  = L.skipLineComment "--"-    blockCmnt = L.skipBlockCommentNested "{-" "-}"--lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc--positiveIntegerLiteral :: Parser Integer-positiveIntegerLiteral = lexeme L.decimal-                     <?> "unsinged integer"--charLiteral :: Parser Char-charLiteral = between (char '\'') (symbol "\'") L.charLiteral-          <?> "character"--stringLiteral :: Parser String-stringLiteral = char '\"' *> manyTill L.charLiteral (symbol "\"")-          <?> "string"--boolLiteral :: Parser Bool-boolLiteral = reserved "True"  $> True-          <|> reserved "False" $> False-          <?> "boolean"--positiveFloatLiteral :: Parser Double-positiveFloatLiteral = lexeme L.float-           <?> "unsigned float"--varLiteral :: Parser Var-varLiteral = stringToVar <$> ident--patVarLiteral :: Parser Var-patVarLiteral = stringToVar <$> (char '$' >> lowerId)---- Parse infix (binary operator) literal.--- If the operator is prefixed with '!', |isWedge| is turned to true.-infixLiteral :: String -> Parser Infix-infixLiteral sym =-  try (do wedge   <- optional (char '!')-          opSym   <- operator' sym-          infixes <- exprInfix <$> get-          let opInfo = fromJust $ find ((== opSym) . repr) infixes-          return $ opInfo { isWedge = isJust wedge })-   <?> "infix"-  where-    -- operator without try-    operator' :: String -> Parser String-    operator' sym = string sym <* notFollowedBy opChar <* sc--reserved :: String -> Parser ()-reserved w = (lexeme . try) (string w *> notFollowedBy identChar)--symbol :: String -> Parser ()-symbol sym = try (L.symbol sc sym) >> pure ()--operator :: String -> Parser String-operator sym = try $ string sym <* notFollowedBy opChar <* sc---- |infixLiteral| for pattern infixes.-patInfixLiteral :: String -> Parser Infix-patInfixLiteral sym =-  try (do opSym <- string sym <* notFollowedBy patOpChar <* sc-          infixes <- patternInfix <$> get-          let opInfo = fromJust $ find ((== opSym) . repr) infixes-          return opInfo)---- Characters that can consist expression operators.-opChar :: Parser Char-opChar = oneOf ("%^&*-+\\|:<>.?!/'#@$" ++ "∧")---- Characters that can consist pattern operators.--- ! ? # @ $ are omitted because they can appear at the beginning of atomPattern-patOpChar :: Parser Char-patOpChar = oneOf "%^&*-+\\|:<>./'"--newPatOp :: Parser String-newPatOp = (:) <$> patOpChar <*> many (patOpChar <|> oneOf "!?#@$")---- Characters that consist identifiers.--- Note that 'alphaNumChar' can also parse greek letters.--- TODO(momohatt): Use more natural way to reject "..."-identChar :: Parser Char-identChar = alphaNumChar-        <|> oneOf (['?', '\'', '/'] ++ mathSymbols)-        <|> try (char '.' <* notFollowedBy (char '.'))---- Non-alphabetical symbols that are allowed for identifiers-mathSymbols :: String-mathSymbols = "∂∇"--parens :: Parser a -> Parser a-parens = between (symbol "(") (symbol ")")--braces :: Parser a -> Parser a-braces = between (symbol "{") (symbol "}")--brackets :: Parser a -> Parser a-brackets  = between (symbol "[") (symbol "]")--comma :: Parser ()-comma = symbol ","---- Notes on identifiers:--- * Identifiers must be able to include greek letters and some symbols in---   |mathSymbols|.--- * Only identifiers starting with capital English letters ('A' - 'Z') can be---   parsed as |upperId|. Identifiers starting with capital Greek letters must---   be regarded as |lowerId|.--lowerId :: Parser String-lowerId = (lexeme . try) (p >>= check)-  where-    p       = (:) <$> satisfy (\c -> c `elem` mathSymbols || isLetter c && not (isAsciiUpper c)) <*> many identChar-    check x = if x `elem` lowerReservedWords-                then fail $ "keyword " ++ show x ++ " cannot be an identifier"-                else return x--upperId :: Parser String-upperId = (lexeme . try) (p >>= check)-  where-    p       = (:) <$> satisfy isAsciiUpper <*> many alphaNumChar-    check x = if x `elem` upperReservedWords-                then fail $ "keyword " ++ show x ++ " cannot be an identifier"-                else return x---- union of lowerId and upperId-ident :: Parser String-ident = (lexeme . try) (p >>= check)-  where-    p       = (:) <$> satisfy (\c -> c `elem` mathSymbols || isLetter c) <*> many identChar-    check x = if x `elem` (lowerReservedWords ++ upperReservedWords)-                then fail $ "keyword " ++ show x ++ " cannot be an identifier"-                else return x--upperReservedWords :: [String]-upperReservedWords =-  [ "True"-  , "False"-  ]--lowerReservedWords :: [String]-lowerReservedWords =-  [ "loadFile"-  , "load"-  , "if"-  , "then"-  , "else"-  -- , "seq"-  , "capply"-  , "memoizedLambda"-  , "cambda"-  , "procedure"-  , "let"-  , "in"-  , "where"-  , "withSymbols"-  , "loop"-  , "forall"-  , "match"-  , "matchDFS"-  , "matchAll"-  , "matchAllDFS"-  , "as"-  , "with"-  , "matcher"-  , "do"-  , "io"-  , "something"-  , "undefined"-  , "algebraicDataMatcher"-  , "generateArray"-  , "arrayBounds"-  , "arrayRef"-  , "generateTensor"-  , "tensor"-  , "contract"-  , "tensorMap"-  , "tensorMap2"-  , "transpose"-  , "subrefs"-  , "subrefs!"-  , "suprefs"-  , "suprefs!"-  , "userRefs"-  , "userRefs!"-  , "function"-  , "infixl"-  , "infixr"-  , "infix"-  ]------- Utils-----makeTupleOrParen :: Parser a -> ([a] -> a) -> Parser a-makeTupleOrParen parser tupleCtor = do-  elems <- parens $ sepBy parser comma-  case elems of-    [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--indentGuardGT :: Pos -> Parser Pos-indentGuardGT pos = L.indentGuard sc GT pos---- Variant of 'some' that requires every element to be at the same indentation level-alignSome :: Parser a -> Parser [a]-alignSome p = do-  pos <- L.indentLevel-  some (indentGuardEQ pos >> p)---- Useful for parsing syntax like function applications, where all 'arguments'--- should be indented deeper than the 'function'.-indentBlock :: Parser a -> Parser b -> Parser (a, [b])-indentBlock phead parg = do-  pos  <- L.indentLevel-  head <- phead-  args <- many (indentGuardGT pos >> parg)-  return (head, args)--indented :: Parser Pos-indented = indentGuardGT pos1--infixToOperator :: (Infix -> Parser (a -> a -> a)) -> Infix -> Operator Parser a-infixToOperator opToParser op =-  case assoc op of-    LeftAssoc  -> InfixL (opToParser op)-    RightAssoc -> InfixR (opToParser op)-    NonAssoc   -> InfixN (opToParser op)
hs-src/Language/Egison/Pretty.hs view
@@ -14,7 +14,6 @@     , showTSV     ) where -import qualified Data.Array                as Array import           Data.Foldable             (toList) import qualified Data.HashMap.Strict       as HashMap import           Data.List                 (intercalate)@@ -34,11 +33,9 @@  instance Pretty EgisonTopExpr where   pretty (Define x (LambdaExpr args body)) =-    hsep (pretty x : map pretty args) <+> group (pretty ":=" <>-      flatAlt (nest 2 (hardline <> pretty body)) (space <> pretty body))+    hsep (pretty x : map pretty args) <+> indentBlock (pretty ":=") [pretty body]   pretty (Define x expr) =-    pretty x <+> group (pretty ":=" <>-      flatAlt (nest 2 (hardline <> pretty expr)) (space <> pretty expr))+    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)@@ -56,14 +53,14 @@   pretty (IndexedExpr True e indices) = pretty' e <> cat (map pretty indices)   pretty (IndexedExpr False e indices) = pretty' e <> pretty "..." <> cat (map pretty indices)   pretty (SubrefsExpr b e1 e2) =-    pretty "subrefs" <> (if b then pretty "!" else emptyDoc) <+>-      pretty' e1 <+> pretty' e2+    applyLike [pretty "subrefs" <> (if b then pretty "!" else emptyDoc),+               pretty' e1, pretty' e2]   pretty (SuprefsExpr b e1 e2) =-    pretty "suprefs" <> (if b then pretty "!" else emptyDoc) <+>-      pretty' e1 <+> pretty' e2+    applyLike [pretty "suprefs" <> (if b then pretty "!" else emptyDoc),+               pretty' e1, pretty' e2]   pretty (UserrefsExpr b e1 e2) =-    pretty "userRefs" <> (if b then pretty "!" else emptyDoc) <+>-      pretty' e1 <+> pretty' e2+    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)) @@ -72,24 +69,29 @@     | length xs < 20 = list (map pretty xs)     | otherwise      =       pretty "[" <> align (fillSepAtom (punctuate comma (map pretty xs))) <> pretty "]"-  pretty (ArrayExpr xs)  = listoid "(|" "|)" (map pretty xs)   pretty (HashExpr xs)   = listoid "{|" "|}" (map (\(x, y) -> tupled [pretty x, pretty y]) xs)   pretty (VectorExpr xs) = listoid "[|" "|]" (map pretty xs) -  pretty (LambdaExpr xs e)          = nest 2 (pretty "\\" <> hsep (map pretty xs) <+> pretty "->" <> softline <> pretty e)-  pretty (CambdaExpr x e)           = nest 2 (pretty "cambda" <+> pretty x <+> pretty "->" <> softline <> pretty e)-  pretty (ProcedureExpr xs e)       = nest 2 (pretty "procedure" <+> hsep (map pretty xs) <+> pretty "->" <> softline <> pretty e)-  pretty (PatternFunctionExpr xs p) = nest 2 (pretty "\\" <> hsep (map pretty xs) <+> pretty "=>" <> softline <> pretty p)+  pretty (LambdaExpr xs e) =+    lambdaLike (pretty "\\") (map pretty xs) (pretty "->") (pretty e)+  pretty (MemoizedLambdaExpr xs e)  =+    lambdaLike (pretty "memoizedLambda ") (map pretty xs) (pretty "->") (pretty e)+  pretty (CambdaExpr x e) =+    indentBlock (pretty "cambda" <+> pretty x <+> pretty "->") [pretty e]+  pretty (ProcedureExpr xs e) =+    lambdaLike (pretty "procedure ") (map pretty xs) (pretty "->") (pretty e)+  pretty (PatternFunctionExpr xs p) =+    lambdaLike (pretty "\\") (map pretty xs) (pretty "=>") (pretty p)    pretty (IfExpr x y z) =-    group (pretty "if" <+> pretty x <>-      (flatAlt (nest 2 (hardline <> pretty "then" <+> pretty y)) (space <> pretty "then" <+> pretty y)) <>-      (flatAlt (nest 2 (hardline <> pretty "else" <+> pretty z)) (space <> pretty "else" <+> pretty z)))+    indentBlock (pretty "if" <+> pretty x)+      [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) = pretty "withSymbols" <+> list (map pretty xs) <+> pretty e+  pretty (WithSymbolsExpr xs e) =+    indentBlock (pretty "withSymbols" <+> list (map pretty xs)) [pretty e]    pretty (MatchExpr BFSMode tgt matcher clauses) =     nest 2 (pretty "match"       <+> pretty tgt <+> prettyMatch matcher clauses)@@ -112,7 +114,7 @@             group (pretty expr) <+> pretty "with" <> hardline <>               align (vsep (map prettyPatBody body)))         prettyPatBody (pdpat, expr) =-          pipe <+> pretty pdpat <+> pretty "->" <+> pretty expr+          indentBlock (pipe <+> align (pretty pdpat) <+> pretty "->") [pretty expr]    pretty (AlgebraicDataMatcherExpr patDefs) =     nest 2 (pretty "algebraicDataMatcher" <> hardline <> align (vsep (map prettyPatDef patDefs)))@@ -129,38 +131,44 @@   -- (x1 op' x2) op y   pretty (BinaryOpExpr op x@(BinaryOpExpr op' _ _) y) =     if priority op > priority op' || priority op == priority op' && assoc op == RightAssoc-       then parens (pretty x) <+> pretty (repr op) <+> pretty'' y-       else pretty x          <+> pretty (repr op) <+> pretty'' y+       then parens (pretty x) <+> pretty op <+> pretty'' y+       else pretty x          <+> pretty op <+> pretty'' y   -- x op (y1 op' y2)   pretty (BinaryOpExpr op x y@(BinaryOpExpr op' _ _)) =     if priority op > priority op' || priority op == priority op' && assoc op == LeftAssoc-       then pretty'' x <+> pretty (repr op) <+> parens (pretty y)-       else pretty'' x <+> pretty (repr op) <+> pretty y-  pretty (BinaryOpExpr op x y) = pretty'' x <+> pretty (repr op) <+> pretty'' y-  pretty (SectionExpr op Nothing Nothing) = parens (pretty (repr op))+       then pretty'' x <+> pretty op <+> parens (pretty y)+       else pretty'' x <+> pretty op <+> pretty y+  pretty (BinaryOpExpr op x y) = pretty'' x <+> pretty op <+> pretty'' y+  pretty (SectionExpr op Nothing Nothing) = parens (pretty op)+  pretty (SectionExpr op (Just x) Nothing) = parens (pretty x <+> pretty op)+  pretty (SectionExpr op Nothing (Just x)) = parens (pretty op <+> pretty x) -  pretty (DoExpr xs y) = pretty "do" <+> align (vsep (map prettyDoBinds xs ++ [pretty y]))+  pretty (DoExpr [] y) = pretty "do" <+> pretty y+  pretty (DoExpr xs (ApplyExpr (VarExpr (Var ["return"] [])) (TupleExpr []))) =+    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 (ApplyExpr x (TupleExpr ys)) = hang 2 (sep (map (group . pretty') (x : ys)))-  pretty (ApplyExpr x y) = hang 2 (sep [group (pretty' x), group (pretty' y)])-  pretty (CApplyExpr e1 e2) = pretty "capply" <+> pretty' e1 <+> pretty' e2+  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 (CApplyExpr e1 e2) = applyLike [pretty "capply", pretty' e1, pretty' e2]   pretty (PartialExpr n e) = pretty n <> pretty '#' <> pretty' e   pretty (PartialVarExpr n) = pretty '%' <> pretty n -  pretty (GenerateArrayExpr gen (size1, size2)) =-    pretty "generateArray" <+> pretty' gen <+> tupled [pretty size1, pretty size2]-  pretty (ArrayBoundsExpr expr) =-    pretty "arrayBounds" <+> pretty' expr-  pretty (ArrayRefExpr expr i) =-    pretty "arrayRef" <+> pretty' expr <+> pretty i--  pretty (GenerateTensorExpr gen shape) = pretty "generateTensor" <+> pretty' gen <+> pretty shape-  pretty (TensorExpr e1 e2) = pretty "tensor" <+> pretty' e1 <+> pretty' e2-  pretty (TensorContractExpr e1 e2) = pretty "contract" <+> pretty' e1 <+> pretty' e2-  pretty (TensorMapExpr e1 e2) = pretty "tensorMap" <+> pretty' e1 <+> pretty' e2-  pretty (TensorMap2Expr e1 e2 e3) = pretty "tensorMap2" <+> pretty' e1 <+> pretty' e2 <+> pretty' e3-  pretty (TransposeExpr e1 e2) = pretty "transpose" <+> pretty' e1 <+> pretty' e2+  pretty (GenerateTensorExpr gen shape) =+    applyLike [pretty "generateTensor", pretty' gen, pretty' shape]+  pretty (TensorExpr e1 e2) =+    applyLike [pretty "tensor", pretty' e1, pretty' e2]+  pretty (TensorContractExpr e1) =+    applyLike [pretty "contract", pretty' e1]+  pretty (TensorMapExpr e1 e2) =+    applyLike [pretty "tensorMap", pretty' e1, pretty' e2]+  pretty (TensorMap2Expr e1 e2 e3) =+    applyLike [pretty "tensorMap2", pretty' e1, pretty' e2, pretty' e3]+  pretty (TransposeExpr e1 e2) =+    applyLike [pretty "transpose", pretty' e1, pretty' e2]   pretty (FlipIndicesExpr _) = error "unreachable"    pretty (FunctionExpr xs) = pretty "function" <+> tupled (map pretty xs)@@ -185,15 +193,13 @@  instance {-# OVERLAPPING #-} Pretty BindingExpr where   pretty ([var], LambdaExpr args body) =-    hsep (pretty var : map pretty args) <+> group (pretty ":=" <>-      flatAlt (nest 2 (hardline <> pretty body)) (space <> pretty 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 {-# OVERLAPPING #-} Pretty MatchClause where   pretty (pat, expr) =-    pipe <+> align (pretty pat) <+> group (pretty "->" <>-      flatAlt (nest 2 (hardline <> pretty expr)) (space <> pretty expr))+    pipe <+> align (pretty pat) <+> indentBlock (pretty "->") [pretty expr]  instance (Pretty a, Complex a) => Pretty (Index a) where   pretty (Subscript i) = pretty '_' <> pretty' i@@ -209,7 +215,10 @@   pretty (PatVar x)   = pretty "$" <> pretty x   pretty (ValuePat v) = pretty "#" <> pretty' v   pretty (PredPat v)  = pretty "?" <> pretty' v-  pretty (IndexedPat p indices) = pretty p <> hcat (map (\i -> pretty '_' <> pretty' i) indices)+  pretty (IndexedPat p indices) =+    pretty p <> hcat (map (\i -> pretty '_' <> pretty' i) indices)+  pretty (LetPat binds pat) =+    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@@ -220,15 +229,18 @@     if priority op > priority op' || priority op == priority op' && assoc op == LeftAssoc        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 (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 ctor xs) = hsep (pretty ctor : map pretty xs)+  pretty (InductivePat "cons" [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 <>       flatAlt (hardline <> group (pretty' p1) <> hardline <> group (pretty' p2))               (space <> pretty' p1 <+> pretty' p2))   pretty ContPat = pretty "..."-  pretty (PApplyPat fn ps) = hang 2 (hsep (pretty' fn : map pretty' ps))+  pretty (PApplyPat fn ps) = applyLike (pretty' fn : map pretty' ps)   pretty (VarPat x) = pretty ('~' : x)   pretty SeqNilPat = pretty "{}"   pretty (SeqConsPat p1 p2) = listoid "{" "}" (f p1 p2)@@ -237,35 +249,36 @@       f p1 (SeqConsPat p2 p3) = pretty p1 : f p2 p3       f p1 p2 = [pretty p1, pretty p2]   pretty LaterPatVar = pretty "@"-  pretty (LetPat binds pat) = pretty "let" <+> align (vsep (map pretty binds)) <+> pretty "in" <+> pretty pat-  pretty (NotPat pat)    = pretty "!" <> pretty' pat-  pretty (TuplePat pats) = tupled $ map pretty pats+  pretty (DApplyPat p ps) = applyLike (map pretty' (p : ps))   pretty _            = pretty "REPLACEME"  instance Pretty LoopRange where   pretty (LoopRange from (ApplyExpr (VarExpr (Var ["from"] []))-                                    (ApplyExpr (VarExpr (Var ["-'"] []))-                                               (TupleExpr [_, IntegerExpr 1]))) pat) =+                                    (BinaryOpExpr (Infix { repr = "-'" }) _ (IntegerExpr 1))) pat) =     tupled [pretty from, pretty pat]   pretty (LoopRange from to pat) = tupled [pretty from, pretty to, pretty pat]  instance Pretty PrimitivePatPattern where   pretty PPWildCard     = pretty "_"   pretty PPPatVar       = pretty "$"-  pretty (PPValuePat x) = pretty ('#' : x)+  pretty (PPValuePat x) = pretty ('#' : '$' : x)   pretty (PPInductivePat x pppats) = hsep (pretty x : map pretty pppats)   pretty (PPTuplePat pppats) = tupled (map pretty pppats)  instance Pretty PrimitiveDataPattern where   pretty PDWildCard   = pretty "_"   pretty (PDPatVar x) = pretty ('$' : x)-  pretty (PDInductivePat x pdpats) = hsep (pretty x : map pretty' pdpats)+  pretty (PDInductivePat x pdpats) = applyLike (pretty x : map pretty' pdpats)   pretty (PDTuplePat pdpats) = tupled (map pretty pdpats)   pretty PDEmptyPat = pretty "[]"-  pretty (PDConsPat pdp1 pdp2) = pretty' pdp1 <> pretty "::" <> pretty'' pdp2-  pretty (PDSnocPat pdp1 pdp2) = pretty "snoc" <+> pretty' pdp1 <+> pretty' pdp2+  pretty (PDConsPat pdp1 pdp2) = pretty'' pdp1 <+> pretty "::" <+> pretty'' pdp2+  pretty (PDSnocPat pdp1 pdp2) = applyLike [pretty "snoc", pretty' pdp1, pretty' pdp2]   pretty (PDConstantPat expr) = pretty expr +instance Pretty Infix where+  pretty op | isWedge op = pretty ("!" ++ repr op)+            | otherwise  = pretty (repr op)+ class Complex a where   isAtom :: a -> Bool   isAtomOrApp :: a -> Bool@@ -273,9 +286,12 @@  instance Complex EgisonExpr where   isAtom (IntegerExpr i) | i < 0  = False+  isAtom (InductiveDataExpr _ []) = True+  isAtom (InductiveDataExpr _ _)  = False   isAtom UnaryOpExpr{}            = False   isAtom BinaryOpExpr{}           = False   isAtom ApplyExpr{}              = False+  isAtom CApplyExpr{}             = False   isAtom LambdaExpr{}             = False   isAtom CambdaExpr{}             = False   isAtom ProcedureExpr{}          = False@@ -291,9 +307,6 @@   isAtom MatchAllLambdaExpr{}     = False   isAtom MatcherExpr{}            = False   isAtom AlgebraicDataMatcherExpr{} = False-  isAtom GenerateArrayExpr{}      = False-  isAtom ArrayBoundsExpr{}        = False-  isAtom ArrayRefExpr{}           = False   isAtom GenerateTensorExpr{}     = False   isAtom TensorExpr{}             = False   isAtom FunctionExpr{}           = False@@ -303,8 +316,9 @@   isAtom TransposeExpr{}          = False   isAtom _                        = True -  isAtomOrApp ApplyExpr{} = True-  isAtomOrApp e           = isAtom e+  isAtomOrApp ApplyExpr{}         = True+  isAtomOrApp InductiveDataExpr{} = True+  isAtomOrApp e                   = isAtom e    isInfix BinaryOpExpr{}  = True   isInfix _               = False@@ -315,9 +329,12 @@   isAtom (InductivePat _ _)  = False   isAtom (InfixPat _ _ _)    = False   isAtom (LoopPat _ _ _ _)   = False+  isAtom (PApplyPat _ [])    = True+  isAtom (PApplyPat _ _)     = False   isAtom _                   = True    isAtomOrApp PApplyPat{} = True+  isAtomOrApp InductivePat{} = True   isAtomOrApp e           = isAtom e    isInfix (InfixPat _ _ _)   = True@@ -330,7 +347,9 @@   isAtom (PDSnocPat _ _)       = False   isAtom _                     = True -  isAtomOrApp = isAtom+  isAtomOrApp PDInductivePat{} = True+  isAtomOrApp PDSnocPat{}      = True+  isAtomOrApp e                = isAtom e    isInfix (PDConsPat _ _) = True   isInfix _               = False@@ -346,7 +365,7 @@ -- Display "hoge" instead of "() := hoge" prettyDoBinds :: BindingExpr -> Doc ann prettyDoBinds ([], expr) = pretty expr-prettyDoBinds (vs, expr) = pretty (vs, expr)+prettyDoBinds (vs, expr) = pretty "let" <+> pretty (vs, expr)  prettyMatch :: EgisonExpr -> [MatchClause] -> Doc ann prettyMatch matcher clauses =@@ -367,6 +386,22 @@     fillSepAtom' (x:xs) =       group (flatAlt (hardline <> x) (space <> x)) <> fillSepAtom' xs +indentBlock :: Doc ann -> [Doc ann] -> Doc ann+indentBlock header bodies =+  group (nest 2 (header <> flatAlt (hardline <> hsepHard bodies) (space <> hsep bodies)))++hsepHard :: [Doc ann] -> Doc ann+hsepHard = concatWith (\x y -> x <> hardline <> y)++lambdaLike :: Doc ann -> [Doc ann] -> Doc ann -> Doc ann -> Doc ann+lambdaLike start [] arrow body =+  indentBlock (start <> pretty "()" <+> arrow) [body]+lambdaLike start args arrow body =+  indentBlock (start <> hsep args <+> arrow) [body]++applyLike :: [Doc ann] -> Doc ann+applyLike = hang 2 . sep . map group+ -- -- Pretty printer for S-expression --@@ -419,7 +454,6 @@   prettyS (InductiveData name vals) = "<" ++ name ++ concatMap ((' ':) . prettyS) vals ++ ">"   prettyS (Tuple vals)      = "[" ++ unwords (map prettyS vals) ++ "]"   prettyS (Collection vals) = "{" ++ unwords (map prettyS (toList vals)) ++ "}"-  prettyS (Array vals)      = "(|" ++ unwords (map prettyS $ Array.elems 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) ++ "|}"
hs-src/Language/Egison/Primitives.hs view
@@ -16,7 +16,6 @@   ) where  import           Control.Monad.Except-import           Control.Monad.Trans.Maybe  import           Data.Foldable             (toList) import           Data.IORef@@ -42,6 +41,7 @@ import           Language.Egison.AST import           Language.Egison.Core import           Language.Egison.Data+import           Language.Egison.IState    (MonadFresh(..)) import           Language.Egison.Parser import           Language.Egison.Pretty import           Language.Egison.MathExpr@@ -154,11 +154,11 @@              , ("b.abs", rationalUnaryOp abs)              , ("b.neg", rationalUnaryOp negate) -             , ("eq?",  eq)-             , ("lt?",  scalarCompare (<))-             , ("lte?", scalarCompare (<=))-             , ("gt?",  scalarCompare (>))-             , ("gte?", scalarCompare (>=))+             , ("equal",  eq)+             , ("lt",  scalarCompare (<))+             , ("lte", scalarCompare (<=))+             , ("gt",  scalarCompare (>))+             , ("gte", scalarCompare (>=))               , ("round",    floatToIntegerOp round)              , ("floor",    floatToIntegerOp floor)@@ -211,47 +211,19 @@              , ("show", show')              , ("showTsv", showTSV') -             , ("empty?", isEmpty')-             , ("uncons", uncons')-             , ("unsnoc", unsnoc')--             , ("bool?", isBool')-             , ("integer?", isInteger')-             , ("rational?", isRational')-             , ("scalar?", isScalar')-             , ("float?", isFloat')-             , ("char?", isChar')-             , ("string?", isString')-             , ("collection?", isCollection')-             , ("array?", isArray')-             , ("hash?", isHash')-             , ("tensor?", isTensor')-             , ("tensorWithIndex?", isTensorWithIndex')+             , ("isBool", isBool')+             , ("isInteger", isInteger')+             , ("isRational", isRational')+             , ("isScalar", isScalar')+             , ("isFloat", isFloat')+             , ("isChar", isChar')+             , ("isString", isString')+             , ("isCollection", isCollection')+             , ("isHash", isHash')+             , ("isTensor", isTensor')               , ("assert", assert)              , ("assertEqual", assertEqual)--             -- for old syntax compatibility-             -- TODO: Delete these after the old syntax is deprecated-             , ("from-math-expr", fromScalarData)-             , ("to-math-expr", toScalarData)-             , ("to-math-expr'", toScalarData)-             , ("tensor-shape", tensorShape')-             , ("tensor-to-list", tensorToList')-             , ("df-order", dfOrder')-             , ("uncons-string", unconsString)-             , ("length-string", lengthString)-             , ("append-string", appendString)-             , ("split-string", splitString)-             , ("regex-cg", regexStringCaptureGroup)-             , ("add-prime", addPrime)-             , ("add-subscript", addSubscript)-             , ("add-superscript", addSuperscript)-             , ("read-process", readProcess')-             , ("read-tsv", readTSV)-             , ("show-tsv", showTSV')-             , ("tensor-with-index?", isTensorWithIndex')-             , ("assert-equal", assertEqual)              ]  unaryOp :: (EgisonData a, EgisonData b) => (a -> b) -> PrimitiveFunc@@ -509,13 +481,13 @@ read' :: PrimitiveFunc read'= oneArg' $ \val -> do   str <- fromEgison val-  ast <- readExpr (T.unpack str)+  ast <- readExpr False (T.unpack str)   evalExprDeep nullEnv ast  readTSV :: PrimitiveFunc readTSV= oneArg' $ \val -> do   str   <- fromEgison val-  exprs <- readExprs (T.unpack str)+  exprs <- readExprs False (T.unpack str)   rets  <- mapM (evalExprDeep nullEnv) exprs   case rets of     [ret] -> return ret@@ -528,26 +500,8 @@ showTSV'= oneArg' $ \val -> return $ toEgison $ T.pack $ showTSV val  ----- Collection----isEmpty' :: PrimitiveFunc-isEmpty' whnf = Value . Bool <$> isEmptyCollection whnf--uncons' :: PrimitiveFunc-uncons' whnf = do-  mRet <- runMaybeT (unconsCollection whnf)-  case mRet of-    Just (carObjRef, cdrObjRef) -> return $ Intermediate $ ITuple [carObjRef, cdrObjRef]-    Nothing -> throwError $ Default "cannot uncons collection"--unsnoc' :: PrimitiveFunc-unsnoc' whnf = do-  mRet <- runMaybeT (unsnocCollection whnf)-  case mRet of-    Just (racObjRef, rdcObjRef) -> return $ Intermediate $ ITuple [racObjRef, rdcObjRef]-    Nothing -> throwError $ Default "cannot unsnoc collection"- -- Test+--  assert ::  PrimitiveFunc assert = twoArgs' $ \label test -> do@@ -583,31 +537,14 @@                , ("writeCharToPort", writeCharToPort)                , ("writeToPort", writeStringToPort) -               , ("eof?", isEOFStdin)+               , ("isEof", isEOFStdin)                , ("flush", flushStdout)-               , ("eofPort?", isEOFPort)+               , ("isEofPort", isEOFPort)                , ("flushPort", flushPort)                , ("readFile", readFile')                 , ("rand", randRange)                , ("f.rand", randRangeDouble)--               -- for old syntax compatibility-               -- TODO: Delete these after the old syntax is deprecated-               , ("open-input-file", makePort ReadMode)-               , ("open-output-file", makePort WriteMode)-               , ("close-input-port", closePort)-               , ("close-output-port", closePort)-               , ("read-char", readChar)-               , ("read-line", readLine)-               , ("write-char", writeChar)-               , ("read-char-from-port", readCharFromPort)-               , ("read-line-from-port", readLineFromPort)-               , ("write-char-to-port", writeCharToPort)-               , ("write-to-port", writeStringToPort)-               , ("eof-port?", isEOFPort)-               , ("flush-port", flushPort)-               , ("read-file", readFile')                ]  makeIO :: EgisonM EgisonValue -> EgisonValue
hs-src/Language/Egison/Tensor.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE TypeOperators         #-}+ {- | Module      : Language.Egison.Tensor Licence     : MIT@@ -32,13 +38,17 @@  import           Prelude                   hiding (foldr, mappend, mconcat) -import           Control.Monad.Except+import           Control.Monad.Except      hiding (join) import qualified Data.Vector               as V-import           Data.List                 (any, delete, elem, find, findIndex,-                                            partition, splitAt, (\\))+import           Data.List                 (delete, find, findIndex,+                                            partition, (\\)) -import           Language.Egison.AST+import           Control.Egison            hiding (Integer)+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  --@@ -144,36 +154,39 @@ changeIndex (Superscript s) m = Superscript (s ++ show m) changeIndex (Subscript s) m   = Subscript (s ++ show m) +-- transIndex [a, b, c] [c, a, b] [2, 3, 4] = [4, 2, 3] transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> [Integer] -> EgisonM [Integer]-transIndex [] [] is = return is-transIndex (j1:js1) js2 is = do-  let (hjs2, tjs2) = break (\j2 -> j1 == j2) js2-  if null tjs2-    then throwError =<< InconsistentTensorIndex <$> getFuncNameStack-    else do let n = length hjs2 + 1-            rs <- transIndex js1 (hjs2 ++ tail tjs2) (take (n - 1) is ++ drop n is)-            return (nth (fromIntegral n) is:rs)-transIndex _ _ _ = throwError =<< InconsistentTensorShape <$> getFuncNameStack+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" |]])+       js  tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM (Tensor a)-tTranspose is t@(Tensor ns _ js) = do-  ns' <- transIndex js is ns-  xs' <- V.fromList <$> mapM (transIndex js is) (enumTensorIndices ns') >>= mapM (`tIntRef` t) >>= mapM fromTensor-  return $ Tensor ns' xs' is+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' :: HasTensor a => [EgisonValue] -> Tensor a -> EgisonM (Tensor a) tTranspose' is t@(Tensor _ _ js) = do-  is' <- g is js-  tTranspose is' t+  case g is js 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] -> EgisonM [Index EgisonValue]+  g :: [EgisonValue] -> [Index EgisonValue] -> Maybe [Index EgisonValue]   g [] _ = return []   g (i:is) js = case find (\j -> i == f j) js of-                  Nothing ->  throwError =<< InconsistentTensorIndex <$> getFuncNameStack+                  Nothing -> Nothing                   Just j' -> do js' <- g is js                                 return $ j':js' @@ -350,12 +363,13 @@       return $ concat tss     _ -> return [t'] +-- TODO: refactor in PMOP tContract' :: HasTensor a => Tensor a -> EgisonM (Tensor a) tContract' t@(Tensor ns _ js) =-  case findPairs p js of-    [] -> return t-    (m,n):_ -> do-      let (hjs, mjs, tjs) = removePairs (m,n) 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)]@@ -385,9 +399,6 @@  -- utility functions for tensors -nth :: Integer -> [a] -> a-nth i xs = xs !! fromIntegral (i - 1)- cdr :: [a] -> [a] cdr []     = [] cdr (_:ts) = ts@@ -402,17 +413,19 @@ getScalar (Scalar x) = return x getScalar _          = throwError $ Default "Inconsitent Tensor order" -findPairs :: (a -> a -> Bool) -> [a] -> [(Int, Int)]-findPairs p xs = reverse $ findPairs' 0 p xs+findPair :: (a -> a -> Bool) -> [a] -> Maybe (Int, Int)+findPair p xs = findPair' 0 p xs -findPairs' :: Int -> (a -> a -> Bool) -> [a] -> [(Int, Int)]-findPairs' _ _ [] = []-findPairs' m p (x:xs) = case findIndex (p x) xs of-                    Just i  -> (m, m + i + 1):findPairs' (m + 1) p xs-                    Nothing -> findPairs' (m + 1) p xs+-- 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 -removePairs :: (Int, Int) -> [a] -> ([a],[a],[a])-removePairs (m, n) xs =          -- (0,1) [i i]+-- 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]
hs-src/Language/Egison/Types.hs view
@@ -24,7 +24,6 @@   , isChar'   , isString'   , isCollection'-  , isArray'   , isHash'   ) where @@ -107,11 +106,6 @@ isCollection' (Value (Collection _))         = return $ Value $ Bool True isCollection' (Intermediate (ICollection _)) = return $ Value $ Bool True isCollection' _                              = return $ Value $ Bool False--isArray' :: PrimitiveFunc-isArray' (Value (Array _))         = return $ Value $ Bool True-isArray' (Intermediate (IArray _)) = return $ Value $ Bool True-isArray' _                         = return $ Value $ Bool False  isHash' :: PrimitiveFunc isHash' (Value (IntHash _))         = return $ Value $ Bool True
− hs-src/Language/Egison/Util.hs 
@@ -1,134 +0,0 @@-{- |-Module      : Language.Egison.Util-Licence     : MIT--This module provides utility functions.--}--module Language.Egison.Util-  ( getEgisonExpr-  , completeEgison-  ) where--import           Control.Monad.Except             (liftIO)-import           Data.List-import           System.Console.Haskeline         hiding (catch, handle, throwTo)-import           System.Console.Haskeline.History (addHistoryUnlessConsecutiveDupe)-import           Text.Regex.TDFA                  ((=~))--import           Language.Egison.AST-import           Language.Egison.CmdOptions-import           Language.Egison.Parser           as Parser-import           Language.Egison.ParserNonS       as ParserNonS---- |Get Egison expression from the prompt. We can handle multiline input.-getEgisonExpr :: EgisonOpts -> InputT IO (Maybe (String, EgisonTopExpr))-getEgisonExpr opts = getEgisonExpr' opts ""--getEgisonExpr' :: EgisonOpts -> String -> InputT IO (Maybe (String, EgisonTopExpr))-getEgisonExpr' opts prev = do-  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 line -> do-      history <- getHistory-      putHistory $ addHistoryUnlessConsecutiveDupe line history-      let input = prev ++ line-      let parsedExpr = (if optSExpr opts then Parser.parseTopExpr else ParserNonS.parseTopExpr) input-      case parsedExpr of-        Left err | show err =~ "unexpected end of input" ->-          getEgisonExpr' opts $ input ++ "\n"-        Left err -> do-          liftIO $ print err-          getEgisonExpr opts-        Right topExpr -> do-          -- outputStr $ show topExpr-          return $ Just (input, topExpr)---- |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--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"]--egisonKeywords :: [String]-egisonKeywords = egisonPrimitivesAfterOpenParen ++ egisonKeywordsAfterOpenParen ++ egisonKeywordsAfterOpenCons ++ egisonKeywordsInNeutral--completeParen :: Monad m => CompletionFunc m-completeParen (lstr, _) = case closeParen lstr of-  Nothing    -> return (lstr, [])-  Just paren -> return (lstr, [Completion paren paren False])--closeParen :: String -> Maybe String-closeParen str = closeParen' 0 $ removeCharAndStringLiteral str--removeCharAndStringLiteral :: String -> String-removeCharAndStringLiteral [] = []-removeCharAndStringLiteral ('"':'\\':str) = '"':'\\':removeCharAndStringLiteral str-removeCharAndStringLiteral ('"':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral ('\'':'\\':str) = '\'':'\\':removeCharAndStringLiteral str-removeCharAndStringLiteral ('\'':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral (c:str) = c:removeCharAndStringLiteral str--removeCharAndStringLiteral' :: String -> String-removeCharAndStringLiteral' []              = []-removeCharAndStringLiteral' ('"':'\\':str)  = removeCharAndStringLiteral' str-removeCharAndStringLiteral' ('"':str)       = removeCharAndStringLiteral str-removeCharAndStringLiteral' ('\'':'\\':str) = removeCharAndStringLiteral' str-removeCharAndStringLiteral' ('\'':str)      = removeCharAndStringLiteral str-removeCharAndStringLiteral' (_:str)         = removeCharAndStringLiteral' str--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/Tool/translator.hs view
@@ -3,15 +3,13 @@ module Main where  import           Control.Arrow                         ((***))-import           Data.Char                             (toUpper) import           Data.List                             (find)-import           Data.List.Split                       (splitOn) import           Data.Maybe                            (fromJust) import           Data.Text.Prettyprint.Doc.Render.Text (putDoc) import           System.Environment                    (getArgs)  import           Language.Egison.AST-import           Language.Egison.Parser+import           Language.Egison.Parser.SExpr import           Language.Egison.Pretty  class SyntaxElement a where@@ -54,7 +52,6 @@       f (SubCollectionExpr x : xs) = BinaryOpExpr append (toNonS x) (f xs)       cons = fromJust $ find (\op -> repr op == "::") reservedExprInfix       append = fromJust $ find (\op -> repr op == "++") reservedExprInfix-  toNonS (ArrayExpr xs)      = ArrayExpr (map toNonS xs)   toNonS (HashExpr xs)       = HashExpr (map (toNonS *** toNonS) xs)   toNonS (VectorExpr xs)     = VectorExpr (map toNonS xs) @@ -76,14 +73,36 @@   toNonS (MatchAllLambdaExpr p xs)    = MatchAllLambdaExpr (toNonS p) (map toNonS xs)    toNonS (MatcherExpr xs) = MatcherExpr (map toNonS xs)+  toNonS (AlgebraicDataMatcherExpr xs) =+    AlgebraicDataMatcherExpr (map (\(s, es) -> (s, map toNonS es)) xs)    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 -> BinaryOpExpr op acc (toNonS x)) (toNonS y) ys+      where+        op =+          let op' = fromJust $ find (\op -> func op == prettyS f) reservedExprInfix+           in op' { isWedge = True }++        optimize (BinaryOpExpr (Infix { repr = "*" }) (IntegerExpr (-1)) e2) =+          UnaryOpExpr "-" (optimize e2)+        optimize (BinaryOpExpr op e1 e2) =+          BinaryOpExpr op (optimize e1) (optimize e2)+        optimize e = e   toNonS (WedgeApplyExpr x y) = WedgeApplyExpr (toNonS x) (toNonS y)    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 -> BinaryOpExpr 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 -> BinaryOpExpr 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 -> BinaryOpExpr op acc (toNonS x)) (toNonS y) ys@@ -99,19 +118,19 @@   toNonS (ApplyExpr x y) = ApplyExpr (toNonS x) (toNonS y)   toNonS (CApplyExpr e1 e2) = CApplyExpr (toNonS e1) (toNonS e2)   toNonS (PartialExpr n e) =-    -- SectionExpr with only one argument omitted is hard to detect correctly.     case PartialExpr n (toNonS e) of       PartialExpr 2 (BinaryOpExpr op (PartialVarExpr 1) (PartialVarExpr 2)) ->         SectionExpr op Nothing Nothing+      -- TODO(momohatt): Check if %1 does not appear freely in e+      -- PartialExpr 1 (BinaryOpExpr op e (PartialVarExpr 1)) ->+      --   SectionExpr op (Just (toNonS e)) Nothing+      -- PartialExpr 1 (BinaryOpExpr op (PartialVarExpr 1) e) ->+      --   SectionExpr op Nothing (Just (toNonS e))       e' -> e' -  toNonS (GenerateArrayExpr e (e1, e2)) = GenerateArrayExpr (toNonS e) (toNonS e1, toNonS e2)-  toNonS (ArrayBoundsExpr e) = ArrayBoundsExpr (toNonS e)-  toNonS (ArrayRefExpr e1 e2) = ArrayRefExpr (toNonS e1) (toNonS e2)-   toNonS (GenerateTensorExpr e1 e2) = GenerateTensorExpr (toNonS e1) (toNonS e2)   toNonS (TensorExpr e1 e2) = TensorExpr (toNonS e1) (toNonS e2)-  toNonS (TensorContractExpr e1 e2) = TensorContractExpr (toNonS e1) (toNonS e2)+  toNonS (TensorContractExpr e1) = TensorContractExpr (toNonS e1)   toNonS (TensorMapExpr e1 e2) = TensorMapExpr (toNonS e1) (toNonS e2)   toNonS (TensorMap2Expr e1 e2 e3) = TensorMap2Expr (toNonS e1) (toNonS e2) (toNonS e3)   toNonS (TransposeExpr e1 e2) = TransposeExpr (toNonS e1) (toNonS e2)@@ -122,15 +141,17 @@ instance SyntaxElement EgisonPattern 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 (NotPat p) = NotPat (toNonS p)   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 ForallPat{} = error "Not supported: forall pattern"   toNonS (TuplePat ps) = TuplePat (map toNonS ps)   toNonS (InductivePat name [p1, p2])     | any (\op -> func op == name) reservedPatternInfix =@@ -140,8 +161,36 @@   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+  toNonS (PPInductivePat x pps) = PPInductivePat x (map toNonS pps)+  toNonS (PPTuplePat pps) = PPTuplePat (map toNonS pps)+  toNonS pp = pp++instance SyntaxElement PrimitiveDataPattern where+  toNonS (PDInductivePat x pds) = PDInductivePat x (map toNonS pds)+  toNonS (PDTuplePat pds) = PDTuplePat (map toNonS pds)+  toNonS (PDConsPat pd1 pd2) = PDConsPat (toNonS pd1) (toNonS pd2)+  toNonS (PDSnocPat pd1 pd2) = PDSnocPat (toNonS pd1) (toNonS pd2)+  toNonS (PDConstantPat e) = PDConstantPat (toNonS e)+  toNonS pd = pd+ instance SyntaxElement LoopRange where   toNonS (LoopRange e1 e2 p) = LoopRange (toNonS e1) (toNonS e2) (toNonS p) @@ -159,16 +208,10 @@   toNonS (pat, body) = (toNonS pat, toNonS body)  instance SyntaxElement PatternDef where-  toNonS (x, y, zs) = (x, toNonS y, map (\(z, w) -> (z, toNonS w)) zs)+  toNonS (x, y, zs) = (toNonS x, toNonS y, map (\(z, w) -> (toNonS z, toNonS w)) zs)  instance SyntaxElement Var where-  toNonS (Var xs ys) = Var (map toCamelCase xs) ys-    where-      toCamelCase :: String -> String-      toCamelCase x@('-':_) = x-      toCamelCase x =-        let heads:tails = splitOn "-" x-         in concat $ heads : map (\(x:xs) -> toUpper x : xs) tails+  toNonS = id   main :: IO ()
lib/core/assoc.egi view
@@ -1,107 +1,94 @@-;;;;;-;;;;;-;;;;; Assoc-Collection-;;;;;-;;;;;--(define $to-assoc-  (lambda [$xs]-    (match xs (list something)-      {[<nil> {}]-       [<cons $x (loop $i [2 $n]-                   <cons ,x ...>-                   (& !<cons ,x _> $rs))>-        {[x n] @(to-assoc rs)}]})))--(define $from-assoc-  (lambda [$xs]-    (match xs (list [something integer])-      {[<nil> {}]-       [<cons [$x $n] $rs>-        {@(take n (repeat1 x)) @(from-assoc rs)}]})))+--+--+-- Assoc-Collection+--+-- -;;;-;;; Assoc List-;;;+toAssoc xs :=+  match xs as list something with+    | [] -> []+    | $x :: (loop $i (2, $n)+               (#x :: ...)+               (!(#x :: _) & $rs)) -> (x, n) :: toAssoc rs -(define $assoc-list-  (lambda [$a]-    (matcher-      {[<nil> []-        {[{} {[]}]-         [_ {}]}]-       [<cons $ $> [a (assoc-list a)]-        {[$tgt (match tgt (list [something integer])-                 {[<cons [$x ,1] $rs> {[x rs]}]-                  [<cons [$x $n] $rs> {[x {[x (- n 1)] @rs}]}]-                  [_ {}]})]}]-       [<ncons $ ,$k $> [a (assoc-list a)]-        {[$tgt (match tgt (list [something integer])-                 {[<cons [$x ,k] $rs> {[x rs]}]-                  [<cons [$x (& ?(gt? $ k) $n)] $rs> {[x {[x (- n k)] @rs}]}]-                  [_ {}]})]}]-       [<ncons $ $ $> [a integer (assoc-list a)]-        {[$tgt (match tgt (list [something integer])-                 {[<cons [$x $k] $rs> {[x k rs]}]-                  [_ {}]})]}]-       [,$val []-        {[$tgt (if (eq? val tgt) {[]} {})]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))+fromAssoc xs :=+  match xs as list (something, integer) with+    | [] -> []+    | ($x, $n) :: $rs -> take n (repeat1 x) ++ fromAssoc rs -;;;-;;; Assoc Multiset-;;;+--+-- Assoc List+--+assocList a :=+  matcher+    | [] as () with+      | [] -> [()]+      | _ -> []+    | $ :: $ as (a, assocList a) with+      | $tgt ->+        match tgt as list (something, integer) with+          | ($x, #1) :: $rs -> [(x, rs)]+          | ($x, $n) :: $rs -> [(x, (x, n - 1) :: rs)]+          | _ -> []+    | ncons $ #$k $ as (a, assocList a) with+      | $tgt ->+        match tgt as list (something, integer) with+          | ($x, #k) :: $rs -> [(x, rs)]+          | ($x, ?(> k) & $n) :: $rs -> [(x, (x, n - k) :: rs)]+          | _ -> []+    | ncons $ $ $ as (a, integer, assocList a) with+      | $tgt ->+        match tgt as list (something, integer) with+          | ($x, $k) :: $rs -> [(x, k, rs)]+          | _ -> []+    | #$val as () with+      | $tgt -> if val = tgt then [()] else []+    | $ as (something) with+      | $tgt -> [tgt] -(define $assoc-multiset-  (lambda [$a]-    (matcher-      {[<nil> []-        {[{} {[]}]-         [_ {}]}]-       [<cons ,$x $> [(assoc-multiset a)]-        {[$tgt (match-all tgt (list [a integer])-                 [<join $hs <cons [,x $n] $ts>>-                  (if (eq? n 1)-                    {@hs @ts}-                    {@hs [x (- n 1)] @ts})])]}]-       [<cons $ $> [a (assoc-multiset a)]-        {[$tgt (match-all tgt (list [a integer])-                 [<join $hs <cons [$x $n] $ts>>-                  (if (eq? n 1)-                    [x {@hs @ts}]-                    [x {@hs [x (- n 1)] @ts}])])]}]-       [<ncons ,$x ,$n $> [(assoc-multiset a)]-        {[$tgt (match-all tgt (list [a integer])-                 [<join $hs <cons [,x (& ?(gte? $ n) $k)] $ts>>-                  (if (eq? (- k n) 0)-                    {@hs @ts}-                    {@hs [x (- k n)] @ts})])]}]-       [<ncons $ ,$n $> [a (assoc-multiset a)]-        {[$tgt (match-all tgt (list [a integer])-                 [<join $hs <cons [$x (& ?(gte? $ n) $k)] $ts>>-                  (if (eq? (- k n) 0)-                    [x {@hs @ts}]-                    [x {@hs [x (- k n)] @ts}])])]}]-       [<ncons ,$x $ $> [integer (assoc-multiset a)]-        {[$tgt (match-all tgt (list [a integer])-                 [<join $hs <cons [,x $n] $ts>>-                  [n {@hs @ts}]])]}]-       [<ncons $ $ $> [a integer (assoc-multiset a)]-        {[$tgt (match-all tgt (list [a integer])-                 [<join $hs <cons [$x $n] $ts>>-                  [x n {@hs @ts}]])]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))+--+-- Assoc Multiset+--+assocMultiset a :=+  matcher+    | [] as () with+      | [] -> [()]+      | _ -> []+    | #$x :: $ as (assocMultiset a) with+      | $tgt ->+        matchAll tgt as list (a, integer) with+          | $hs ++ (#x, $n) :: $ts ->+            if n = 1 then hs ++ ts else hs ++ (x, n - 1) :: ts+    | $ :: $ as (a, assocMultiset a) with+      | $tgt ->+        matchAll tgt as list (a, integer) with+          | $hs ++ ($x, $n) :: $ts ->+            if n = 1 then (x, hs ++ ts) else (x, hs ++ (x, n - 1) :: ts)+    | ncons #$x #$n $ as (assocMultiset a) with+      | $tgt ->+        matchAll tgt as list (a, integer) with+          | $hs ++ (#x, ?(>= n) & $k) :: $ts ->+            if k - n = 0 then hs ++ ts else hs ++ (x, k - n) :: ts+    | ncons $ #$n $ as (a, assocMultiset a) with+      | $tgt ->+        matchAll tgt as list (a, integer) with+          | $hs ++ ($x, ?(>= n) & $k) :: $ts ->+            if k - n = 0 then (x, hs ++ ts) else (x, hs ++ (x, k - n) :: ts)+    | ncons #$x $ $ as (integer, assocMultiset a) with+      | $tgt ->+        matchAll tgt as list (a, integer) with+          | $hs ++ (#x, $n) :: $ts -> (n, hs ++ ts)+    | ncons $ $ $ as (a, integer, assocMultiset a) with+      | $tgt ->+        matchAll tgt as list (a, integer) with+          | $hs ++ ($x, $n) :: $ts -> (x, n, hs ++ ts)+    | $ as (something) with+      | $tgt -> [tgt] -(define $AC.intersect-  (lambda [$xs $ys]-    (match-all [xs ys] [(assoc-multiset something) (assoc-multiset something)]-      [[<ncons $x $m _> <ncons ,x $n _>] [x (min {m n})]])))+AC.intersect xs ys :=+  matchAll (xs, ys) as (assocMultiset something, assocMultiset something) with+    | (ncons $x $m _, ncons #x $n _) -> (x, min [m, n]) -(define $AC.intersect/m-  (lambda [$a $xs $ys]-    (match-all [xs ys] [(assoc-multiset a) (assoc-multiset a)]-      [[<ncons $x $m _> <ncons ,x $n _>] [x (min {m n})]])))+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
@@ -1,94 +1,61 @@-;;;;;-;;;;;-;;;;; Base-;;;;;-;;;;;--(define $eq-  (matcher-    {[,$val []-      {[$tgt (if (eq? val tgt)-                 {[]}-                 {})]}]-     [$ [something]-      {[$tgt {tgt}]}]-     }))-  -(define $bool eq)-(define $char eq)-(define $integer eq)-(define $float eq)+--+--+-- Base+--+-- -;;-;; Utility-;;-(define $id 1#%1)+eq :=+  matcher+    | #$val as () with+      | $tgt -> if val = tgt then [()] else []+    | $ as (something) with+      | $tgt -> [tgt] -(define $fst 2#%1)+bool := eq+char := eq+integer := eq+float := eq -(define $snd 2#%2)+--+-- Utility+-- -(define $apply-  (lambda [$f $x]-    (f x)))+id := 1#%1 -(define $b.compose-  (lambda [$f $g]-    (lambda $x-      (g (f x)))))+fst := 2#%1 -(define $compose-  (cambda $fs-    (lambda $x-      (foldl 2#(%2 %1) x fs))))+snd := 2#%2 -(define $flip (lambda [$fn] (lambda [$x $y] (fn y x))))+apply f x := f x -(define $ref-  (lambda [%xa $is]-    (match is (list integer)-      {[<nil> xa]-       [<cons $i $rs> (ref (array-ref xa i) rs)]})))+compose f g := \x -> g (f x) -(define $eq?/m-  (lambda [$a $x $y]-    (match x a-      {[,y #t]-       [_ #f]})))+flip fn := \$x $y -> fn y x -;;-;; Boolean-;;-(define $and (cambda $bs (foldl b.and #t bs)))-(define $or (cambda $bs (foldl b.or #f bs)))+eqAs a x y :=+  match x as a with+    | #y -> True+    | _ -> False -(define $b.and-  (lambda [$b1 $b2]-    (if b1-        b2-        #f)))+--+-- Boolean+-- -(define $b.or-  (lambda [$b1 $b2]-    (if b1-        #t-        b2)))+(&&) b1 b2 := if b1 then b2 else False+(||) b1 b2 := if b1 then True else b2 -(define $not-  (lambda [$b]-    (match b bool-      {[,#t #f]-       [,#f #t]})))+not b :=+  match b as bool with+    | #True -> False+    | #False -> True -;;-;; Unordered Pair-;;+--+-- Unordered Pair+-- -(define $unordered-pair-  (lambda [$m]-    (matcher-      {[[$ $] [m m]-        {[[$x $y] {[x y] [y x]}]}]-       [$ [eq]-        {[$tgt {tgt}]}]-       })))+unorderedPair m :=+  matcher+    | ($, $) as (m, m) with+      | ($x, $y) -> [(x, y), (y, x)]+    | $ as (eq) with+      | $tgt -> [tgt]
lib/core/collection.egi view
@@ -1,613 +1,515 @@-;;;;;-;;;;;-;;;;; Collection-;;;;;-;;;;;+--+--+-- Collection+--+-- -;;;-;;; List-;;;-(define $list-  (lambda [$a]-    (matcher-      {[<nil> []-        {[{} {[]}]-         [_ {}]}]-       [<cons $ $> [a (list a)]-        {[{$x @$xs} {[x xs]}]-         [_ {}]}]-       [<snoc $ $> [a (list a)]-        {[{@$xs $x} {[x xs]}]-         [_ {}]}]-       [<join _ $> [(list a)]-        {[$tgt (match-all tgt (list a)-                 [(loop $i [1 _] <cons _ ...> $rs) rs])]}]-       [<join $ $> [(list a) (list a)]-        {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(foldr (lambda [%i %r] {xa_i @r}) {} (between 1 n))-                                                         rs]])]}]-       [<nioj $ $> [(list a) (list a)]-        {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <snoc $xa_i ...> $rs) [(foldr (lambda [%i %r] {@r xa_i}) {} (between 1 n))-                                                         rs]])]}]-       [,$val []-        {[$tgt (if (eq? val tgt) {[]} {})]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))+--+-- List+--+list a :=+  matcher+    | [] as () with+      | [] -> [()]+      | _ -> []+    | $ :: $ as (a, list a) with+      | $x :: $xs -> [(x, xs)]+      | _ -> []+    | snoc $ $ as (a, list a) with+      | snoc $xs $x -> [(x, xs)]+      | _ -> []+    | _ ++ $ as (list a) with+      | $tgt ->+        matchAll tgt as list a with+          | loop $i (1, _)+              (_ :: ...)+              $rs -> rs+    | $ ++ $ as (list a, list a) with+      | $tgt ->+        matchAll tgt as list a with+          | loop $i (1, $n)+              ($xa_i :: ...)+              $rs -> (foldr (\%i %r -> xa_i :: r) [] [1..n], rs)+    | nioj $ $ as (list a, list a) with+      | $tgt ->+        matchAll tgt as list a with+          | loop $i (1, $n)+              (snoc $xa_i ...)+              $rs -> (foldr (\%i %r -> r ++ [xa_i]) [] [1..n], rs)+    | #$val as () with+      | $tgt -> if val = tgt then [()] else []+    | $ as (something) with+      | $tgt -> [tgt] -(define $sorted-list-  (lambda [$a]-    (matcher-      {[<nil> []-        {[{} {[]}]-         [_ {}]}]-       [<join $ <cons ,$px $>> [(sorted-list a) (sorted-list a)]-        {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <cons (& ?(lt? $ px) $xa_i) ...> <cons ,px $rs>)-                  [(map (lambda [$i] xa_i) (between 1 n))-                   rs]])]}]-       [<join $ $> [(sorted-list a) (sorted-list a)]-        {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <cons $xa_i ...> $rs)-                  [(map (lambda [$i] xa_i) (between 1 n))-                   rs]])]}]-       [<cons $ $> [a (sorted-list a)]-        {[{$x @$xs} {[x xs]}]-         [_ {}]}]-       [,$val []-        {[$tgt (if (eq? val tgt) {[]} {})]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))+sortedList a :=+  matcher+    | [] as () with+      | [] -> [()]+      | _ -> []+    | $ ++ #$px :: $ as (sortedList a, sortedList a) with+      | $tgt ->+        matchAll tgt as list a with+          | loop $i (1, $n)+              ((?(< px) & $xa_i) :: ...)+              (#px :: $rs) -> (map (\i -> xa_i) [1..n], rs)+    | $ ++ $ as (sortedList a, sortedList a) with+      | $tgt ->+        matchAll tgt as list a with+          | loop $i (1, $n)+              ($xa_i :: ...)+              $rs -> (map (\i -> xa_i) [1..n], rs)+    | $ :: $ as (a, sortedList a) with+      | $x :: $xs -> [(x, xs)]+      | _ -> []+    | #$val as () with+      | $tgt -> if val = tgt then [()] else []+    | $ as (something) with+      | $tgt -> [tgt] -;;-;; Accessors-;;-(define $nth-  (lambda [$n $xs]-    (match xs (list something)-      {[(loop $i [1 (- n 1)]-          <cons _ ...>-          <cons $x _>)-        x]})))+--+-- Accessors+--+nth n xs :=+  match xs as list something with+    | loop $i (1, n - 1, _)+        (_ :: ...)+        ($x :: _) -> x -(define $take-and-drop-  (lambda [$n $xs]-    (match xs (list something)-      {[(loop $i [1 n] <cons $a_i ...> $rs)-        [(map (lambda [$i] a_i) (between 1 n)) rs]]})))+takeAndDrop n xs :=+  match xs as list something with+    | loop $i (1, n, _)+        ($a_i :: ...)+        $rs -> (map (\i -> a_i) [1..n], rs) -(define $take-  (lambda [$n $xs]-    (if (eq? n 0)-        {}-        (match xs (list something)-          {[<cons $x $xs> {x @(take (- n 1) xs)}]-           [<nil> {}]}))))+take n xs :=+  if n = 0+    then []+    else match xs as list something with+      | $x :: $xs -> x :: take (n - 1) xs+      | [] -> [] -(define $drop-  (lambda [$n $xs]-    (if (eq? n 0)-        xs-        (match xs (list something)-          {[<cons _ $xs> (drop (- n 1) xs)]-           [<nil> {}]}))))+drop n xs :=+  if n = 0+    then xs+    else match xs as list something with+      | _ :: $xs -> drop (n - 1) xs+      | [] -> [] -(define $take-while-  (lambda [$pred $xs]-    (match xs (list something)-      {[<nil> {}]-       [<cons $x $rs>-        (if (pred x)-            {x @(take-while pred rs)}-            {})]})))+takeWhile pred xs :=+  match xs as list something with+    | [] -> []+    | $x :: $rs -> if pred x then x :: takeWhile pred rs else [] -(define $take-while-by-  (lambda [$pred $xs]-    (match xs (list something)-      {[<nil> {}]-       [<cons $x $rs>-        (if (pred x)-            {x @(take-while-by pred rs)}-            {x})]})))+takeWhileBy pred xs :=+  match xs as list something with+    | [] -> []+    | $x :: $rs -> if pred x then x :: takeWhileBy pred rs else [x] -(define $taile-until-  (lambda [$pred $xs]-    (match xs (list something)-      {[<nil> {}]-       [<cons $x $rs>-        (if (not (pred x))-            {x @(take-until pred rs)}-            {})]})))+taileUntil pred xs :=+  match xs as list something with+    | [] -> []+    | $x :: $rs -> if not (pred x) then x :: takeUntil pred rs else [] -(define $take-until-by-  (lambda [$pred $xs]-    (match xs (list something)-      {[<nil> {}]-       [<cons $x $rs>-        (if (not (pred x))-            {x @(take-until-by pred rs)}-            {x})]})))+takeUntilBy pred xs :=+  match xs as list something with+    | [] -> []+    | $x :: $rs -> if not (pred x) then x :: takeUntilBy pred rs else [x] -(define $drop-while-  (lambda [$pred $xs]-    (match xs (list something)-      {[<nil> {}]-       [<cons $x $rs>-        (if (pred x)-            (drop-while pred rs)-            xs)]})))+dropWhile pred xs :=+  match xs as list something with+    | [] -> []+    | $x :: $rs -> if pred x then dropWhile pred rs else xs -;;-;; cons, car, cdr-;;-(define $cons-  (lambda [$x $xs] {x @xs}))+--+-- head, tail, uncons, unsnoc+--+head xs :=+  match xs as list something with+    | $x :: _ -> x -(define $car-  (lambda [$xs]-    (match xs (list something)-      {[<cons $x _> x]})))+tail xs :=+  match xs as list something with+    | _ :: $ys -> ys -(define $cdr-  (lambda [$xs]-    (match xs (list something)-      {[<cons _ $ys> ys]})))+last xs :=+  match xs as list something with+    | snoc $x _ -> x -(define $rac-  (lambda [$xs]-    (match xs (list something)-      {[<snoc $x _> x]})))+init xs :=+  match xs as list something with+    | snoc _ $ys -> ys -(define $rdc-  (lambda [$xs]-    (match xs (list something)-      {[<snoc _ $ys> ys]})))+uncons xs :=+  match xs as list something with+    | $x :: $ys -> (x, ys) -;;-;; list functions-;;-(define $length-  (lambda [$xs]-    (foldl 2#(+ %1 1) 0 xs)))+unsnoc xs :=+  match xs as list something with+    | snoc $x $ys -> (ys, x) -(define $map-  (lambda [$fn $xs]-    (match xs (list something)-      {[<nil> {}]-       [<cons $x $rs> {(fn x) @(map fn rs)}]}))) -(define $map2-  (lambda [$fn $xs $ys]-    (match [xs ys] [(list something) (list something)]-      {[[<nil> _] {}]-       [[_ <nil>] {}]-       [[<cons $x $xs2> <cons $y $ys2>]-        {(fn x y) @(map2 fn xs2 ys2)}]})))+--+-- list functions+--+isEmpty xs :=+  match xs as list something with+    | [] -> True+    | _  -> False -(define $map3-  (lambda [$fn $xs $ys $zs]-    (match [xs ys zs] [(list something) (list something) (list something)]-      {[[<nil> _ _] {}]-       [[_ <nil> _] {}]-       [[_ _ <nil>] {}]-       [[<cons $x $xs2> <cons $y $ys2> <cons $z $zs2>]-        {(fn x y z) @(map3 fn xs2 ys2 zs2)}]})))+length xs := foldl 2#(%1 + 1) 0 xs -(define $map4-  (lambda [$fn $xs $ys $zs $ws]-    (match [xs ys zs ws] [(list something) (list something) (list something) (list something)]-      {[[<nil> _ _ _] {}]-       [[_ <nil> _ _] {}]-       [[_ _ <nil> _] {}]-       [[_ _ _ <nil>] {}]-       [[<cons $x $xs2> <cons $y $ys2> <cons $z $zs2> <cons $w $ws2>]-        {(fn x y z w) @(map4 fn xs2 ys2 zs2 ws2)}]})))+map fn xs :=+  match xs as list something with+    | [] -> []+    | $x :: $rs -> fn x :: map fn rs -(define $filter-  (lambda [$pred $xs]-    (foldr (lambda [%y %ys] (if (pred y) {y @ys} ys))-           {}-           xs)))+map2 fn xs ys :=+  match (xs, ys) as (list something, list something) with+    | ([], _) -> []+    | (_, []) -> []+    | ($x :: $xs2, $y :: $ys2) -> fn x y :: map2 fn xs2 ys2 -(define $partition-  (lambda [$pred $xs]-    [(filter pred xs) (filter 1#(not (pred %1)) xs)]))+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 -(define $zip-  (lambda [$xs $ys]-    (map2 (lambda [$x $y] [x y]) xs ys)))+map4 fn xs ys zs ws :=+  match (xs, ys, zs, ws) as+    (list something, list something, list something, list something) with+    | ([], _, _, _) -> []+    | (_, [], _, _) -> []+    | (_, _, [], _) -> []+    | (_, _, _, []) -> []+    | ($x :: $xs2, $y :: $ys2, $z :: $zs2, $w :: $ws2) ->+      fn x y z w :: map4 fn xs2 ys2 zs2 ws2 -(define $zip3-  (lambda [$xs $ys $zs]-    (map3 (lambda [$x $y $z] [x y z]) xs ys zs)))+filter pred xs := foldr (\%y %ys -> if pred y then y :: ys else ys) [] xs -(define $zip4-  (lambda [$xs $ys $zs $ws]-    (map4 (lambda [$x $y $z $w] [x y z w]) xs ys zs ws)))+partition pred xs := (filter pred xs, filter 1#(not (pred %1)) xs) -(define $lookup-  (lambda [$k $ls]-    (match ls (list [something something])-      {[<join _ <cons [,k $x] _>> x]})))+zip xs ys := map2 (\x y -> (x, y)) xs ys -; Note. `foldr` is used in the definition of the list matcher.-(define $foldr-  (lambda [$fn %init %ls]-    (match ls (list something)-      {[<nil> init]-       [<cons $x $xs> (fn x (foldr fn init xs))]})))+zip3 xs ys zs := map3 (\x y z -> (x, y, z)) xs ys zs -(define $foldl-  (lambda [$fn %init %ls]-    (match ls (list something)-      {[<nil> init]-       [<cons $x $xs>-        (let {[$z (fn init x)]}-          (seq z (foldl fn z xs)))]})))+zip4 xs ys zs ws := map4 (\x y z w -> (x, y, z, w)) xs ys zs ws -(define $reduce-  (lambda [$fn %ls]-    (foldl fn (car ls) (cdr ls))))+lookup k ls :=+  match ls as list (something, something) with+    | _ ++ (#k, $x) :: _ -> x -(define $scanl-  (lambda [$fn %init %ls]-    {init @(match ls (list something)-             {[<nil> {}]-              [<cons $x $xs> (scanl fn (fn init x) xs)]})}))+foldr fn %init %ls :=+  match ls as list something with+    | [] -> init+    | $x :: $xs -> fn x (foldr fn init xs) -(define $iterate-  (lambda [$fn %x]-    (let* {[$nx1 (fn x)]-           [$nx2 (fn nx1)]-           [$nx3 (fn nx2)]-           [$nx4 (fn nx3)]-           [$nx5 (fn nx4)]}-      {x nx1 nx2 nx3 nx4 @(iterate fn nx5)})))+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) -(define $repeated-squaring-  (lambda [$fn %x $n]-    (match n integer-      {[,1 x]-       [?even? (let {[$y (repeated-squaring fn x (quotient n 2))]}-                 (fn y y))]-       [?odd? (let {[$y (repeated-squaring fn x (quotient n 2))]}-                (fn (fn y y) x))]})))+foldl1 fn %ls := foldl fn (head ls) (tail ls) -(define $append-  (lambda [$xs $ys]-    {@xs @ys}))+reduce fn %ls := foldl fn (head ls) (tail ls) -(define $concat-  (lambda [$xss]-    (foldr (lambda [%xs %rs] {@xs @rs})-           {}-           xss)))+scanl fn %init %ls :=+  init :: (match ls as list something with+    | [] -> []+    | $x :: $xs -> scanl fn (fn init x) xs) -(define $reverse-  (lambda [$xs]-    (match xs (list something)-      {[<nil> {}]-       [<snoc $x $rs>-        {x @(reverse rs)}]})))+iterate fn %x :=+  let nx1 := fn x+      nx2 := fn nx1+      nx3 := fn nx2+      nx4 := fn nx3+      nx5 := fn nx4+   in x :: nx1 :: nx2 :: nx3 :: nx4 :: iterate fn nx5 -(define $intersperse-  (lambda [$in $ws]-    (match ws (list something)-      {[<nil> {}]-       [<cons $w $rs> (foldl (lambda [$s1 $s2] {@s1 in s2}) {w} rs)]})))+repeatedSquaring fn %x n :=+  match n as integer with+    | #1 -> x+    | ?isEven ->+      let y := repeatedSquaring fn x (quotient n 2)+       in fn y y+    | ?isOdd ->+      let y := repeatedSquaring fn x (quotient n 2)+       in fn (fn y y) x -(define $intercalate (compose intersperse concat))+append xs ys := xs ++ ys -(define $split-  (lambda [$in $ls]-    (match ls (list something)-      {[<join $xs <join ,in $rs>> {xs @(split in rs)}]-       [_ {ls}]})))+concat xss := foldr (\%xs %rs -> xs ++ rs) [] xss -(define $split/m-  (lambda [$a $in $ls]-    (match ls (list a)-      {[<join $xs <join ,in $rs>> {xs @(split/m a in rs)}]-       [_ {ls}]})))+reverse xs :=+  match xs as list something with+    | [] -> []+    | snoc $x $rs -> x :: reverse rs -(define $find-cycle-  (lambda [$xs]-    (car (match-all xs (list something)-           [<join $ys <join (& <cons _ _> $cs) <join ,cs _>>>-            [ys cs]]))))+intersperse sep ws :=+  match ws as list something with+    | [] -> []+    | $w :: $rs -> foldl (\s1 s2 -> s1 ++ [sep, s2]) [w] rs -(define $repeat-  (lambda [%xs]-    {@xs @(repeat xs)}))+intercalate := compose intersperse concat -(define $repeat1-  (lambda [%x]-    {x @(repeat1 x)}))+split sep ls :=+  match ls as list something with+    | $xs ++ #sep ++ $rs -> xs :: split sep rs+    | _ -> [ls] -;;-;; Others-;;-(define $all-  (lambda [$pred $xs]-    (match xs (list something)-      {[<nil> #t]-       [<cons $x $rs>-        (if (pred x)-            (all pred rs)-            #f)]})))+splitAs a sep ls :=+  match ls as list a with+    | $xs ++ #sep ++ $rs -> xs :: splitAs a sep rs+    | _ -> [ls] -(define $any-  (lambda [$pred $xs]-    (match xs (list something)-      {[<nil> #f]-       [<cons $x $rs>-        (if (pred x)-            #t-            (any pred rs))]})))+findCycle xs :=+  head+    (matchAll xs as list something with+      | $ys ++ (_ :: _ & $cs) ++ #cs ++ _ -> (ys, cs)) -(define $from-  (lambda [$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))}))+repeat %xs := xs ++ repeat xs -; Note. `between` is used in the definition of the list matcher.-(define $between-  (lambda [$s $e]-    (if (eq? s e)-      {s}-      (if (lt? s e)-        {s @(between (+ s 1) e)}-        {}))))+repeat1 %x := x :: repeat1 x -(define $L./-  (lambda [$xs $ys]-    (if (lt? (length xs) (length ys))-      [{} xs]-      (match [ys xs] [(list math-expr) (list math-expr)]-        {-         [[<cons $y $yrs> <cons $x $xrs>]-          (let {[[$zs $rs] (L./ {@(map2 - (take (length yrs) xrs) (map (* $ (/ x y)) yrs))-                                 @(drop (length yrs) xrs)} ys)]}-            [{(/ x y) @zs} rs])]-         }))))+--+-- Others+--+all pred xs :=+  match xs as list something with+    | [] -> True+    | $x :: $rs -> if pred x then all pred rs else False -;;;-;;; Multiset-;;;-(define $multiset-  (lambda [$a]-    (matcher-      {[<nil> []-        {[{} {[]}]-         [_ {}]}]-       [<cons $ _> [a]-        {[$tgt tgt]}]-       [<cons $ $> [a (multiset a)]-        {[$tgt (match-all tgt (list a)-                 [<join $hs <cons $x $ts>> [x {@hs @ts}]])]}]-       [<join ,$pxs $> [(multiset a)]-        {[$tgt (match [pxs tgt] [(list a) (multiset a)]-                 {[(loop $i [1 (length pxs)]-                     {[<cons $x_i #> <cons ,x_i #>]-                      @...}-                     [<nil> $rs])-                   {rs}]-                  [_ {}]})]}]-       [<join $ $> [(multiset a) (multiset a)]-        {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <join $rs_i <cons $x_i ...>> $ts)-                  [(map (lambda [$i] x_i) (between 1 n))-                   (concat {@(map (lambda [$i] rs_i) (between 1 n)) ts})]])]}]-       [,$val []-        {[$tgt (match [val tgt] [(list a) (multiset a)]-                 {[[<nil> <nil>] {[]}]-                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]-                  [[_ _] {}]})]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))+any pred xs :=+  match xs as list something with+    | [] -> False+    | $x :: $rs -> if pred x then True else any pred rs -;;-;; multiset operation-;;-(define $add-  (lambda [$x $xs]-    (if (member? x xs)-      xs-      {@xs x})))+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) -(define $add/m-  (lambda [$a $x $xs]-    (if (member?/m a x xs)-      xs-      {@xs x})))+-- Note. `between` is used in the definition of the list matcher.+between s e :=+  if s = e then [s] else if s < e then s :: between (s + 1) e else [] -(define $delete-first-  (lambda [%x $xs]-    (match xs (list something)-      {[<nil> {}]-       [<cons ,x $rs> rs]-       [<cons $y $rs> {y @(delete-first x rs)}]})))+L./ xs ys :=+  if length xs < length ys+    then ([], xs)+    else match (ys, xs) as (list mathExpr, list mathExpr) with+      | ($y :: $yrs, $x :: $xrs) ->+        let (zs, rs) := L./+                          (map2+                             (-)+                             (take (length yrs) xrs)+                             (map 1#(%1 * (x / y)) yrs) ++ drop (length yrs) xrs)+                          ys+         in (x / y :: zs, rs) -(define $delete-first/m-  (lambda [$a %x $xs]-    (match xs (list a)-      {[<nil> {}]-       [<cons ,x $rs> rs]-       [<cons $y $rs> {y @(delete-first/m a x rs)}]})))+--+-- Multiset+--+multiset a :=+  matcher+    | [] as () with+      | [] -> [()]+      | _ -> []+    | $ :: _ as (a) with+      | $tgt -> tgt+    | $ :: $ as (a, multiset a) with+      | $tgt ->+        matchAll tgt as list a with+          | $hs ++ $x :: $ts -> (x, hs ++ ts)+    | #$pxs ++ $ as (multiset a) with+      | $tgt ->+        match (pxs, tgt) as (list a, multiset a) with+          | loop $i (1, length pxs, _)+              {($x_i :: @, #x_i :: @), ...}+              ([], $rs) -> [rs]+          | _ -> []+    | $ ++ $ as (multiset a, multiset a) with+      | $tgt ->+        matchAll tgt as list a with+          | loop $i (1, $n)+              ($rs_i ++ $x_i :: ...)+              $ts ->+            (map (\i -> x_i) [1..n], concat (map (\i -> rs_i) [1..n] ++ [ts]))+    | #$val as () with+      | $tgt ->+        match (val, tgt) as (list a, multiset a) with+          | ([], []) -> [()]+          | ($x :: $xs, #x :: #xs) -> [()]+          | (_, _) -> []+    | $ as (something) with+      | $tgt -> [tgt] -(define $delete-  (lambda [$x $xs]-    (match xs (list something)-      {[<nil> {}]-       [<join $hs <cons ,x $ts>> {@hs @(delete x ts)}]-       [_ xs]})))+--+-- multiset operation+--+deleteFirst %x xs :=+  match xs as list something with+    | [] -> []+    | #x :: $rs -> rs+    | $y :: $rs -> y :: deleteFirst x rs -(define $delete/m-  (lambda [$a $x $xs]-    (match xs (list a)-      {[<nil> {}]-       [<join $hs <cons ,x $ts>> {@hs @(delete/m a x ts)}]-       [_ xs]})))+deleteFirstAs a %x xs :=+  match xs as list a with+    | [] -> []+    | #x :: $rs -> rs+    | $y :: $rs -> y :: deleteFirstAs a x rs -(define $difference-  (lambda [$xs $ys]-    (match ys (list something)-      {[<nil> xs]-       [<cons $y $rs> (difference (delete-first y xs) rs)]})))+delete x xs :=+  match xs as list something with+    | [] -> []+    | $hs ++ #x :: $ts -> hs ++ delete x ts+    | _ -> xs -(define $difference/m-  (lambda [$a $xs $ys]-    (match ys (list a)-      {[<nil> xs]-       [<cons $y $rs> (difference/m a (delete-first/m a y xs) rs)]})))+deleteAs a x xs :=+  match xs as list a with+    | [] -> []+    | $hs ++ #x :: $ts -> hs ++ deleteAs a x ts+    | _ -> xs -(define $include?-  (lambda [$xs $ys]-    (match ys (list something)-      {[<nil> #t]-       [<cons $y $rs>-        (if (member? y xs)-          (include? (delete-first y xs) rs)-          #f)]})))+difference xs ys :=+  match ys as list something with+    | [] -> xs+    | $y :: $rs -> difference (deleteFirst y xs) rs -(define $include?/m-  (lambda [$a $xs $ys]-    (match ys (list a)-      {[<nil> #t]-       [<cons $y $rs>-        (if (member?/m a y xs)-          (include?/m a (delete-first y xs) rs)-          #f)]})))+differenceAs a xs ys :=+  match ys as list a with+    | [] -> xs+    | $y :: $rs -> differenceAs a (deleteFirstAs a y xs) rs -(define $union-  (lambda [$xs $ys]-    {@xs-     @(match-all [ys xs] [(multiset something) (multiset something)]-        [[<cons $y _> !<cons ,y _>] y])-     }))+include xs ys :=+  match ys as list something with+    | [] -> True+    | $y :: $rs ->+      if member y xs then include (deleteFirst y xs) rs else False -(define $union/m-  (lambda [$a $xs $ys]-    {@xs-     @(match-all [ys xs] [(multiset a) (multiset a)]-        [[<cons $y _> !<cons ,y _>] y])-     }))+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 -(define $intersect-  (lambda [$xs $ys]-    (match-all [xs ys] [(multiset something) (multiset something)]-      [[<cons $x _> <cons ,x _>] x])))+union xs ys :=+  xs ++ (matchAll (ys, xs) as (multiset something, multiset something) with+    | ($y :: _, !(#y :: _)) -> y) -(define $intersect/m-  (lambda [$a $xs $ys]-    (match-all [xs ys] [(multiset a) (multiset a)]-      [[<cons $x _> <cons ,x _>] x])))+unionAs a xs ys :=+  xs ++ (matchAll (ys, xs) as (multiset a, multiset a) with+    | ($y :: _, !(#y :: _)) -> y) -;;-;; Simple predicate-;;-(define $member?-  (lambda [$x $ys]-    (match ys (list something)-      {[<join _ <cons ,x _>> #t]-       [_ #f]})))+intersect xs ys :=+  matchAll (xs, ys) as (multiset something, multiset something) with+    | ($x :: _, #x :: _) -> x -(define $member?/m-  (lambda [$a $x $ys]-    (match ys (list a)-      {[<join _ <cons ,x _>> #t]-       [_ #f]})))+intersectAs a xs ys :=+  matchAll (xs, ys) as (multiset a, multiset a) with+    | ($x :: _, #x :: _) -> x -;;-;; Counting-;;-(define $count-  (lambda [$x $xs]-    (foldl (match-lambda [something something]-             {[[$r ,x] (+ r 1)]-              [[$r $y] r]})-           0-           xs)))+--+-- Simple predicate+--+member x ys :=+  match ys as list something with+    | _ ++ #x :: _ -> True+    | _ -> False -(define $count/m-  (lambda [$a $x $xs]-    (foldl (match-lambda [a a]-             {[[$r ,x] (+ r 1)]-              [[$r $y] r]})-           0-           xs)))+memberAs a x ys :=+  match ys as list a with+    | _ ++ #x :: _ -> True+    | _ -> False -(define $frequency-  (lambda [$xs]-    (let {[$us (unique xs)]}-      (map (lambda [$u] [u (count u xs)]) us))))+--+-- Counting+--+count x xs :=+  foldl+    (\match as (something, something) with+      | ($r, #x) -> r + 1+      | ($r, $y) -> r)+    0+    xs -(define $frequency/m-  (lambda [$a $xs]-    (let {[$us (unique/m a xs)]}-      (map (lambda [$u] [u (count/m a u xs)]) us))))+countAs a x xs :=+  foldl+    (\match as (a, a) with+      | ($r, #x) -> r + 1+      | ($r, $y) -> r)+    0+    xs -;;-;; Index-;;-(define $elemIndices-  (lambda [$x $xs]-    (match-all xs (list something)-      [<join $hs <cons ,x _>> (+ 1 (length hs))])))+frequency xs :=+  let us := unique xs+   in map (\u -> (u, count u xs)) us -;;;-;;; Set-;;;-(define $set-  (lambda [$a]-    (matcher-      {[<nil> []-        {[{} {[]}]-         [_ {}]}]-       [<cons $ $> [a (set a)]-        {[$tgt (match-all tgt (list a)-                 [<join _ <cons $x _>> [x tgt]])]}]-       [<join ,$pxs $> [(set a)]-        {[$tgt (match [pxs tgt] [(list a) (set a)]-                 {[[(loop $i [1 $n] <cons $x_i ...> <nil>)-                    (loop $i [1 n] <cons ,x_i ...> _)]-                   {tgt}]-                  [_ {}]})]}]-       [<join $ $> [(set a) (set a)]-       {[$tgt (match-all tgt (list a)-                 [(loop $i [1 $n] <join $rs_i <cons $x_i ...>> $ts)-                  [(map (lambda [$i] x_i) (between 1 n))-                   tgt]])]}]-       [,$val []-        {[$tgt (match [(unique val) (unique tgt)] [(list a) (multiset a)]-                 {[[<nil> <nil>] {[]}]-                  [[<cons $x $xs> <cons ,x ,xs>] {[]}]-                  [[_ _] {}]})]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))+frequencyAs a xs :=+  let us := uniqueAs a xs+   in map (\u -> (u, countAs a u xs)) us -;;-;; set operation-;;-(define $fast-unique-  (lambda [$xs]-    (match-all (sort xs) (list something)-      [<join _ <cons $x !<cons ,x _>>> x])))+--+-- Index+--+elemIndices x xs :=+  matchAll xs as list something with+    | $hs ++ #x :: _ -> 1 + length hs -(define $unique-  (lambda [$xs]-    (reverse (match-all (reverse xs) (list something)-               [<join _ <cons $x !<join _ <cons ,x _>>>> x]))))+--+-- Set+--+set a :=+  matcher+    | [] as () with+      | [] -> [()]+      | _ -> []+    | $ :: $ as (a, set a) with+      | $tgt ->+        matchAll tgt as list a with+          | _ ++ $x :: _ -> (x, tgt)+    | #$pxs ++ $ as (set a) with+      | $tgt ->+        match (pxs, tgt) as (list a, set a) with+          | ( loop $i (1, $n) ($x_i :: ...) []+            , loop $i (1, n)  (#x_i :: ...) _ ) -> [tgt]+          | _ -> []+    | $ ++ $ as (set a, set a) with+      | $tgt ->+        matchAll tgt as list a with+          | loop $i (1, $n)+              ($rs_i ++ $x_i :: ...)+              $ts -> (map (\i -> x_i) [1..n], tgt)+    | #$val as () with+      | $tgt ->+        match (unique val, unique tgt) as (list a, multiset a) with+          | ([], []) -> [()]+          | ($x :: $xs, #x :: #xs) -> [()]+          | (_, _) -> []+    | $ as (something) with+      | $tgt -> [tgt] -(define $unique/m-  (lambda [$a $xs]-    (letrec {[$loop-fn-              (lambda [$xs $ys]-                (match [xs ys] [(list a) (multiset a)]-                  {[[<nil> _] ys]-                   [[<cons $x $rs> <cons ,x _>] (loop-fn rs ys)]-                   [[<cons $x $rs>  _] (loop-fn rs {@ys x})]}))]}-      (loop-fn xs {}))))+--+-- set operation+--+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]++fastUnique xs :=+  matchAll sort xs as list something with+    | _ ++ $x :: !(#x :: _) -> x++unique xs :=+  reverse+    (matchAll reverse xs as list something with+      | _ ++ $x :: !(_ ++ #x :: _) -> x)++uniqueAs a xs := loopFn xs []+  where+    loopFn xs ys :=+      match (xs, ys) as (list a, multiset a) with+        | ([], _) -> ys+        | ($x :: $rs, #x :: _) -> loopFn rs ys+        | ($x :: $rs, _) -> loopFn rs (ys ++ [x])
lib/core/io.egi view
@@ -1,85 +1,77 @@-;;;;;;-;;;;;;-;;;;;; IO-;;;;;;-;;;;;;+--+--+-- IO+--+-- -;;;-;;; IO-;;;-(define $print-  (procedure [$x]-    (do {[(write x)]-         [(write "\n")]-         [(flush)]-         })))+--+-- IO+--+print :=+  procedure x ->+    do write x+       write "\n"+       flush () -(define $print-to-port-  (procedure [$port $x]-    (do {[(write-to-port port x)]-         [(write-to-port port "\n")]-         })))+printToPort :=+  procedure port x ->+    do writeToPort port x+       writeToPort port "\n" -(define $display-  (procedure [$x]-    (do {[(write x)]-         [(flush)]-         })))+display :=+  procedure x ->+    do write x+       flush () -(define $display-to-port-  (procedure [$port $x]-    (do {[(write-to-port port x)]-         })))+displayToPort := procedure port x -> do writeToPort port x -(define $each-line-  (procedure [$proc]-    (do {[$eof (eof?)]}-      (if eof-        (return [])-        (do {[$line (read-line)]-             [(proc line)]}-          (each-line proc))))))+eachLine :=+  procedure proc ->+    do let eof := isEof ()+       if eof+         then return ()+         else do let line := readLine ()+                 proc line+                 eachLine proc -(define $each-line-from-port-  (procedure [$port $proc]-    (do {[$eof (eof-port? port)]}-      (if eof-        (return [])-        (do {[$line (read-line-from-port port)]-             [(proc line)]}-          (each-line-from-port port proc))))))+eachLineFromPort :=+  procedure port proc ->+    do let eof := isEofPort port+       if eof+         then return ()+         else do let line := readLineFromPort port+                 proc line+                 eachLineFromPort port proc -(define $each-file-  (procedure [$files $proc]-    (match files (list string)-      {[<nil> (return [])]-       [<cons $file $rest>-        (do {[$port (open-input-file file)]-             [(each-line-from-port port proc)]-             [(close-input-port port)]}-          (each-file rest proc))]})))+eachFile :=+  procedure files proc ->+    match files as list string with+      | [] -> return ()+      | $file :: $rest ->+        do let port := openInputFile file+           eachLineFromPort port proc+           closeInputPort port+           eachFile rest proc -;;;-;;; Collection-;;;-(define $each-  (procedure [$proc $xs]-    (match xs (list something)-      {[<nil> (do {})]-       [<cons $x $rs>-        (do {[(proc x)]}-          (each proc rs))]})))+--+-- Collection+--+each :=+  procedure proc xs ->+    match xs as list something with+      | [] -> do return ()+      | $x :: $rs ->+        do proc x+           each proc rs -;;;-;;; Debug-;;;-(define $debug-  (lambda [%expr]-    (io (do {[(print (show expr))]}-          (return expr)))))+--+-- Debug+--+debug %expr :=+  io do print (show expr)+        return expr -(define $debug2-  (lambda [%msg %expr]-    (io (do {[(display msg)]-             [(print (show expr))]}-          (return expr)))))+debug2 %msg %expr :=+  io do display msg+        print (show expr)+        return expr
lib/core/maybe.egi view
@@ -1,16 +1,16 @@-;;;;;-;;;;;-;;;;; Maybe (Option)-;;;;;-;;;;;--(define $Nothing {})-(define $Just (lambda [$x] {x}))--(define $nothing (pattern-function [] <nil>))-(define $just (pattern-function [$pat] <cons pat _>))--(define $maybe (lambda [$a] (list a)))+--+--+-- Maybe (Option)+--+-- -;(match-all (Just 1) (maybe integer) [(nothing) "error"]) ; {}-;(match-all (Just 1) (maybe integer) [(just $x) x]) ; {1}+maybe a :=+  matcher+    | nothing as () with+      | Nothing -> [()]+      | _ -> []+    | just $ as (a) with+      | Just $x -> [x]+      | _ -> []+    | $ as (something) with+      | $tgt -> [tgt]
lib/core/number.egi view
@@ -1,192 +1,177 @@-;;;;;-;;;;;-;;;;; Number-;;;;;-;;;;;--;;;-;;; Natural Numbers-;;;-(define $nat-  (matcher-    {[<o> []-      {[0 {[]}]-       [_ {}]}]-     [<s $> nat-      {[$tgt (match (compare tgt 0) ordering-               {[<greater> {(- tgt 1)}]-                [_ {}]})]}]-     [,$n []-      {[$tgt (if (eq? tgt n) {[]} {})]}]-     [$ [something]-      {[$tgt {tgt}]}]-     }))+--+--+-- Number+--+-- -(define $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 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 @(map (+ 100 $) nats)})+--+-- Natural Numbers+--+nat :=+  matcher+    | o as () with+      | 0 -> [()]+      | _ -> []+    | s $ as nat with+      | $tgt ->+        match compare tgt 0 as ordering with+          | greater -> [tgt - 1]+          | _ -> []+    | #$n as () with+      | $tgt -> if tgt = n then [()] else []+    | $ as (something) with+      | $tgt -> [tgt] -(define $nats0 {0 @nats})+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,+   31, 32, 33, 34, 35, 36, 37, 38, 39, 40,+   41, 42, 43, 44, 45, 46, 47, 48, 49, 50,+   51, 52, 53, 54, 55, 56, 57, 58, 59, 60,+   61, 62, 63, 64, 65, 66, 67, 68, 69, 70,+   71, 72, 73, 74, 75, 76, 77, 78, 79, 80,+   81, 82, 83, 84, 85, 86, 87, 88, 89, 90,+   91, 92, 93, 94, 95, 96, 97, 98, 99, 100] +++    map (+ 100) nats -(define $odds {1 @(map (+ $ 2) odds)})+nats0 := 0 :: nats -(define $evens {2 @(map (+ $ 2) evens)})+odds := 1 :: map (+ 2) odds -(define $fibs {1 1 @(map2 + fibs (cdr fibs))})+evens := 2 :: map (+ 2) evens -(define $prime?-  (match-lambda integer-    {[?(lt? $ 2) #f]-     [$n (eq? n (find-factor n))]}))+fibs := [1, 1] ++ map2 (+) fibs (tail fibs) -(define $primes {2 @(filter prime? (drop 2 nats))})+isPrime :=+  \match as integer with+    | ?(< 2) -> False+    | $n -> n = findFactor n -(define $divisor?-  (lambda [$n $d]-    (eq? 0 (remainder n d))))+primes := 2 :: filter isPrime (drop 2 nats) -(define $find-factor-  (memoized-lambda [$n]-    (match (take-while (lte? $ (floor (sqrt (itof n)))) primes) (list integer)-      {[<join _ <cons (& ?(divisor? n $) $x) _>> x]-       [_ n]})))+divisor n d := 0 = n % d -(define $prime-factorization-  (match-lambda integer-    {[,1 {}]-     [(& ?(lt? $ 0) $n) {-1 @(prime-factorization (neg n))}]-     [$n (let {[$p (find-factor n)]}-           {p @(prime-factorization (quotient n p))})]}))+findFactor :=+  memoizedLambda n ->+    match takeWhile (<= floor (sqrt (itof n))) primes as list integer with+      | _ ++ (?1#(divisor n %1) & $x) :: _ -> x+      | _ -> n -(define $p-f prime-factorization)+primeFactorization :=+  \match as integer with+    | #1 -> []+    | ?(< 0) & $n -> (-1) :: primeFactorization (neg n)+    | $n ->+      let p := findFactor n+       in p :: primeFactorization (quotient n p) -(define $even?-  (lambda [$n]-    (eq? 0 (modulo n 2))))+pF := primeFactorization -(define $odd?-  (lambda [$n]-    (eq? 1 (modulo n 2))))+isEven n := 0 = modulo n 2 -(define $fact-  (lambda [$n]-    (foldl * 1 (between 1 n))))+isOdd n := 1 = modulo n 2 -(define $perm-  (lambda [$n $r]-    (foldl * 1 (between (- n (- r 1)) n))))+fact n := foldl (*) 1 [1..n] -(define $comb-  (lambda [$n $r]-    (/ (perm n r)-       (fact r))))+perm n r := foldl (*) 1 [(n - (r - 1))..n] -(define $n-adic-  (lambda [$n $x]-    (if (eq? x 0)-      {}-      (let {[$q (quotient x n)]-            [$r (remainder x n)]}-        {@(n-adic n q) r}))))+comb n r := perm n r / fact r -;;;-;;; Integers-;;;-(define $mod-  (lambda [$m]-    (matcher-      {[,$n []-        {[$tgt (if (eq? (modulo tgt m) (modulo n m))-                   {[]}-                   {})]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))+nAdic n x :=+  if x = 0+    then []+    else let q := quotient x n+             r := x % n+          in nAdic n q ++ [r] -;;;-;;; Floats-;;;-(define $exp2-  (lambda [$x $y]-    (exp (* (log x) y))))+--+-- Integers+--+mod m :=+  matcher+    | #$n as () with+      | $tgt -> if modulo tgt m = modulo n m then [()] else []+    | $ as (something) with+      | $tgt -> [tgt] -;;;-;;; Decimal Fractions-;;;-(define $rtod-helper-  (lambda [$m $n]-    (let {[$q (quotient (* m 10) n)]-          [$r (remainder (* m 10) n)]}-      {[q r] @(rtod-helper r n)})))+--+-- Floats+--+exp2 x y := exp (log x * y) -(define $rtod-  (lambda [$x]-    (let* {[$m (numerator x)]-           [$n (denominator x)]-           [$q (quotient m n)]-           [$r (remainder m n)]}-      [q (map fst (rtod-helper r n))])))+--+-- Decimal Fractions+--+rtodHelper m n :=+  let q := quotient (m * 10) n+      r := m * 10 % n+   in (q, r) :: rtodHelper r n -(define $rtod'-  (lambda [$x]-    (let* {[$m (numerator x)]-           [$n (denominator x)]-           [$q (quotient m n)]-           [$r (remainder m n)]-           [[$s $c] (find-cycle (rtod-helper r n))]}-      [q (map fst s) (map fst c)])))+rtod x :=+  let m := numerator x+      n := denominator x+      q := quotient m n+      r := m % n+   in (q, map fst (rtodHelper r n)) -(define $show-decimal-  (lambda [$c $x]-    (match (2#[%1 (take c %2)] (rtod x)) [integer (list integer)]-      {[[$q $sc] (foldl S.append (S.append (show q) ".") (map show sc))]})))+rtod' x :=+  let m := numerator x+      n := denominator x+      q := quotient m n+      r := m % n+      (s, c) := findCycle (rtodHelper r n)+   in (q, map fst s, map fst c) -(define $show-decimal'-  (lambda [$x]-    (match (rtod' x) [integer (list integer) (list integer)]-      {[[$q $s $c] (foldl S.append "" {(S.append (show q) ".") @(map show s) " " @(map show c) " ..."})]})))+showDecimal c x :=+  match 2#(%1, take c %2) (rtod x) as (integer, list integer) with+    | ($q, $sc) -> foldl S.append (S.append (show q) ".") (map show sc) -;;;-;;; Continued Fraction-;;;-(define $regular-continued-fraction-  (lambda [$n $as]-    (+ n-       (foldr (lambda [$a $r] (/ 1 (+ a r)))-              0-              as))))+showDecimal' x :=+  match rtod' x as (integer, list integer, list integer) with+    | ($q, $s, $c) ->+      foldl+        S.append+        ""+        (S.append (show q) "." :: map show s ++ " " :: map show c ++ [" ..."]) -(define $continued-fraction-  (lambda [$n $as $bs]-    (match [as bs] [(list integer) (list integer)]-      {[[<cons $a $as> <cons $b $bs>]-        (+ n (/ b (continued-fraction a as bs)))]-       [[<nil> <nil>] n]})))+--+-- Continued Fraction+--+regularContinuedFraction n xs := n + foldr (\a r -> 1 / (a + r)) 0 xs -(define $regular-continued-fraction-of-sqrt-helper-  (lambda [$m $a $b] ; a+b*rt(m)-    (let* {[$n (floor (f.+ (rtof a) (f.* (rtof b) (sqrt (rtof m)))))]-           [$x (- m (power n 2))]}-      (if (eq? x 0)-        {[a b n]}-        (let {[$y (- (power (- n a) 2) (* b b m))]}-          {[a b n] @(regular-continued-fraction-of-sqrt-helper m (/ (- a n) y) (neg (/ b y)))})))))+continuedFraction n xs ys :=+  match (xs, ys) as (list integer, list integer) with+    | ($x :: $xs, $y :: $ys) -> n + y / continuedFraction x xs ys+    | ([], []) -> n -(define $regular-continued-fraction-of-sqrt-  (lambda [$m]-    (let* {[$n (floor (sqrt (rtof m)))]-           [$x (- m (power n 2))]}-      ; n+rt(m)-n-      ; n+(rt(m)-n)*(rt(m)+n)/(rt(m)+n)-      ; n+x/(rt(m)+n)-      (if (eq? x 0)-        [n {} {}]-        [n (map 3#%3 (regular-continued-fraction-of-sqrt-helper m (/ n x) (/ 1 x)))]))))+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+        then [(a, b, n)]+        else let y := power (n - a) 2 - b * b * m+              in (a, b, n) :: regularContinuedFractionOfSqrtHelper+                                m+                                ((a - n) / y)+                                (neg (b / y)) -(define $regular-continued-fraction-of-sqrt'-  (lambda [$m]-    (let* {[$n (floor (sqrt (rtof m)))]-           [$x (- m (power n 2))]}-      (if (eq? x 0)-        [n {} {}]-        (let {[[$s $c] (find-cycle (regular-continued-fraction-of-sqrt-helper m (/ n x) (/ 1 x)))]}-          [n (map 3#%3 s) (map 3#%3 c)])))))+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)) ) +regularContinuedFractionOfSqrt' m :=+  let n := floor (sqrt (rtof m))+      x := m - power n 2+   in if x = 0+        then (n, [], [])+        else let (s, c) := findCycle+                             (regularContinuedFractionOfSqrtHelper+                                m+                                (n / x)+                                (1 / x))+              in (n, map 3#%3 s, map 3#%3 c)
lib/core/order.egi view
@@ -1,100 +1,83 @@-;;;;;-;;;;;-;;;;; Order-;;;;;-;;;;;+--+--+-- Order+--+-- -(define $ordering-  (algebraic-data-matcher -    {<less> <equal> <greater>}))+ordering :=+  algebraicDataMatcher+    | less+    | equal+    | greater -(define $compare-  (lambda [$m $n]-    (if (collection? m)-      (compare-c m n)-      (if (lt? m n)-        <Less>-        (if (eq? m n)-          <Equal>-          <Greater>)))))+compare m n :=+  if isCollection m+    then compareC m n+    else if m < n then Less else if m = n then Equal else Greater -(define $compare-c-  (lambda [$c1 $c2]-    (match [c1 c2] [(list something) (list something)]-      {[[<nil> <nil>] <Equal>]-       [[<nil> _] <Less>]-       [[_ <nil>] <Greater>]-       [[<cons $x $xs> <cons ,x $ys>] (compare-c xs ys)]-       [[<cons $x _> <cons $y _>] (compare x y)]})))+compareC c1 c2 :=+  match (c1, c2) as (list something, list something) with+    | ([], []) -> Equal+    | ([], _) -> Less+    | (_, []) -> Greater+    | ($x :: $xs, #x :: $ys) -> compareC xs ys+    | ($x :: _, $y :: _) -> compare x y -(define $b.min-  (lambda [$x $y]-    (if (lt? x y) x y)))+min $x $y := if x < y then x else y -(define $b.max-  (lambda [$x $y]-    (if (gt? x y) x y)))+max $x $y := if x > y then x else y -(define $min/fn-  (lambda [$f $xs]-    (foldl 2#(if (eq? (f %1 %2) <Less>) %1 %2) (car xs) (cdr xs))))+min/fn f $xs := foldl1 2#(if f %1 %2 = Less then %1 else %2) xs -(define $max/fn-  (lambda [$f $xs]-    (foldl 2#(if (eq? (f %1 %2) <Greater>) %1 %2) (car xs) (cdr xs))))+max/fn f $xs := foldl1 2#(if f %1 %2 = Greater then %1 else %2) xs -(define $min (lambda [$xs] (foldl b.min (car xs) (cdr xs))))-(define $max (lambda [$xs] (foldl b.max (car xs) (cdr xs))))+minimum $xs := foldl1 min xs -(define $split-by-ordering (split-by-ordering/fn compare $ $))+maximum $xs := foldl1 max xs -(define $split-by-ordering/fn-  (lambda [$f $p $xs]-    (match xs (list something)-      {[<nil> [{} {} {}]]-       [<cons $x $rs>-        (let {[[$ys1 $ys2 $ys3] (split-by-ordering/fn f p rs)]}-          (match (f x p) ordering-            {[<less> [{x @ys1} ys2 ys3]]-             [<equal> [ys1 {x @ys2} ys3]]-             [<greater> [ys1 ys2 {x @ys3}]]}))]})))+splitByOrdering := 2#(splitByOrdering/fn compare %1 %2) -(define $sort (sort/fn compare $))+splitByOrdering/fn f p xs :=+  match xs as list something with+    | [] -> ([], [], [])+    | $x :: $rs ->+      let (ys1, ys2, ys3) := splitByOrdering/fn f p rs+       in match f x p as ordering with+            | less -> (x :: ys1, ys2, ys3)+            | equal -> (ys1, x :: ys2, ys3)+            | greater -> (ys1, ys2, x :: ys3) -(define $sort/fn-  (lambda [$f $xs]-    (match xs (list something)-      {[<nil> {}]-       [<cons $x <nil>> {x}]-       [_ (let* {[$n (length xs)]-                 [$p (nth (quotient n 2) xs)]-                 [[$ys1 $ys2 $ys3] (split-by-ordering/fn f p xs)]}-            {@(sort/fn f ys1) @ys2 @(sort/fn f ys3)})]})))+sort := 1#(sort/fn compare %1) -(define $sort-strings-  (lambda [$xs]-    (sort/fn 2#(compare-c (map ctoi (unpack %1)) (map ctoi (unpack %2))) xs)))+sort/fn f xs :=+  match xs as list something with+    | [] -> []+    | $x :: [] -> [x]+    | _ ->+      let n := length xs+          p := nth (quotient n 2) xs+          (ys1, ys2, ys3) := splitByOrdering/fn f p xs+       in sort/fn f ys1 ++ ys2 ++ sort/fn f ys3 -(define $merge-  (lambda [$xs $ys]-    (match [xs ys] [(list something) (list something)]-      {[[<nil> _] ys]-       [[_ <nil>] xs]-       [[<cons $x $txs> <cons ?(gte? $ x) _>] {x @(merge txs ys)}]-       [[_ <cons $y $tys>] {y @(merge xs tys)}]})))+sortStrings xs :=+  sort/fn 2#(compareC (map ctoi (unpack %1)) (map ctoi (unpack %2))) xs -(define $merge/fn-  (lambda [$f $xs $ys]-    (match [xs ys] [(list something) (list something)]-      {[[<nil> _] ys]-       [[_ <nil>] xs]-       [[<cons $x $txs> <cons ?1#(eq? (f %1 x) <Greater>) _>] {x @(merge txs ys)}]-       [[_ <cons $y $tys>] {y @(merge xs tys)}]})))+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 -(define $minimize-  (lambda [$f $xs]-    (foldl 2#(if (eq? (compare (f %1) (f %2)) <Less>) %1 %2) (car xs) (cdr xs))))+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 -(define $maximize-  (lambda [$f $xs]-    (foldl 2#(if (eq? (compare (f %1) (f %2)) <Greater>) %1 %2) (car xs) (cdr xs))))+minimize f xs :=+  foldl1 2#(if compare (f %1) (f %2) = Less then %1 else %2) xs++maximize f xs :=+  foldl1 2#(if compare (f %1) (f %2) = Greater then %1 else %2) xs
lib/core/random.egi view
@@ -1,83 +1,76 @@-;;;;;-;;;;; Random-;;;;;+--+--+-- Random+--+-- -(define $rands-  (lambda [$s $e]-    {(pure-rand s e) @(rands s e)}))+rands s e := pureRand s e :: rands s e -(define $pure-rand-  (lambda [$s $e]-    (io (rand s e))))+pureRand s e := io rand s e -(define $randomize-  (lambda [$xs]-    (letrec {[$randomize'-              (lambda [$xs $n]-                (if (eq? n 0)-                  {}-                  (let* {[$r (pure-rand 1 n)]-                         [$x (nth r xs)]}-                    {x @(randomize' (delete-first x xs) (- n 1))})))]}-      (randomize' xs (length xs)))))+randomize xs :=+  let randomize' xs n :=+        if n = 0+          then []+          else let r := pureRand 1 n+                   x := nth r xs+                in x :: randomize' (deleteFirst x xs) (n - 1)+   in randomize' xs (length xs) -(define $R.between-  (lambda [$s $e]-    (randomize (between s e))))+R.between s e := randomize [s..e] -(define $R.multiset-  (lambda [$a]-    (matcher-      {[<nil> []-        {[{} {[]}]-         [_ {}]}]-       [<cons $ $> [a (R.multiset a)]-        {[$tgt (map (lambda [$i]-                      (match tgt (list a)-                        {[(loop $j [1 (- i 1)] <cons $xa_j ...> <cons $x $ts>)-                          [x {@(map (lambda [$j] xa_j) (between 1 (- i 1))) @ts}]]}))-                    (R.between 1 (length tgt)))]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))+R.multiset a :=+  matcher+    | [] as () with+      | [] -> [()]+      | _ -> []+    | $ :: $ as (a, R.multiset a) with+      | $tgt ->+        map+          (\i ->+            match tgt as list a with+              | loop $j (1, i - 1, _)+                  ($xa_j :: ...)+                  ($x :: $ts) ->+                (x, map (\j -> xa_j) [1..(i - 1)] ++ ts))+          (R.between 1 (length tgt))+    | $ as (something) with+      | $tgt -> [tgt] -(define $R.uncons-  (lambda [$xs]-    (car (match-all xs (R.multiset something)-           [<cons $x $rs> [x rs]]))))+R.uncons xs :=+  head+    (matchAll xs as R.multiset something with+      | $x :: $rs -> (x, rs)) -(define $R.car-  (lambda [$xs]-    (car (match-all xs (R.multiset something)-           [<cons $x $rs> x]))))+R.head xs :=+  head+    (matchAll xs as R.multiset something with+      | $x :: $rs -> x) -(define $R.cdr-  (lambda [$xs]-    (car (match-all xs (R.multiset something)-           [<cons $x $rs> rs]))))+R.tail xs :=+  head+    (matchAll xs as R.multiset something with+      | $x :: $rs -> rs) -(define $sample R.car)+sample := R.head -(define $R.set-  (lambda [$a]-    (matcher-      {[<nil> []-        {[{} {[]}]-         [_ {}]}]-       [<cons $ $> [a (R.multiset a)]-        {[$tgt (map (lambda [$i]-                      (match tgt (list a)-                        {[(loop $j [1 (- i 1)] <cons _ ...> <cons $x _>)-                          [x tgt]]}))-                    (R.between 1 (length tgt)))]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))+R.set a :=+  matcher+    | [] as () with+      | [] -> [()]+      | _ -> []+    | $ :: $ as (a, R.multiset a) with+      | $tgt ->+        map+          (\i ->+            match tgt as list a with+              | loop $j (1, i - 1, _)+                  (_ :: ...)+                  ($x :: _) -> (x, tgt))+          (R.between 1 (length tgt))+    | $ as (something) with+      | $tgt -> [tgt] -(define $f.rands-  (lambda [$s $e]-    {(f.pure-rand s e) @(f.rands s e)}))+f.rands s e := f.pureRand s e :: f.rands s e -(define $f.pure-rand-  (lambda [$s $e]-    (io (f.rand s e))))+f.pureRand s e := io f.rand s e
− lib/core/sexpr.egi 
@@ -1,24 +0,0 @@-(define $sortedList sorted-list)-(define $unorderedPair unordered-pair)-(define $takeAndDrop take-and-drop)-(define $takeWhile take-while)-(define $dropWhile drop-while)-(define $deleteFirst delete-first)-(define $deleteFirst/m delete-first/m)-(define $upperCase upper-case)-(define $lowerCase lower-case)-(define $findFactor find-factor)-(define $pF p-f)-(define $nAdic n-adic)-(define $showDecimal show-decimal)-(define $showDecimal' show-decimal')-(define $regularContinuedFraction regular-continued-fraction)-(define $continuedFraction continued-fraction)-(define $regularContinuedFractionOfSqrt regular-continued-fraction-of-sqrt)-(define $findCycle find-cycle)-(define $qF' q-f')-(define $taylorExpansion taylor-expansion)-(define $multivariateTaylorExpansion multivariate-taylor-expansion)--(define $dfNormalize df-normalize)-(define $antisymmetrize df-normalize)
lib/core/shell.egi view
@@ -1,58 +1,53 @@-(define $SH.gen-input-  (lambda [$sopts $copts]-    (if (io (eof?))-      {}-      (let {[$x (io (TSV.read-line sopts copts))]}-        (seq x {x @(SH.gen-input sopts copts)})))))+SH.genInput sopts copts :=+  if io isEof ()+    then []+    else let x := io TSV.readLine sopts copts+          in seq x (x :: SH.genInput sopts copts) -(define $TSV.read-line-  (lambda [$sopts $copts]-    (do {[$line (read-line)]}-      (let {[$fs (S.split "\t" line)]}-        (letrec {[$fn-s (match-lambda [(list (list integer)) (list string)]-                          {[[<nil> $fs] fs]-                           [[<cons <cons $m <nil>> $opts'>-                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))-                                   $ts>]-                            (fn-s opts' {@hs @(map (lambda [$t] (S.concat {"\"" t "\""})) ts)})]-                           [[<cons <cons $m <cons ,m <nil>>> $opts'>-                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))-                                   <cons $mf $ts>>]-                            (fn-s opts' {@hs (S.concat {"\"" mf "\""}) @ts})]-                           [[<cons <cons $m <cons $n <nil>>> $opts'>-                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))-                                   <join (& $ms ?(lambda [$ms] (eq? (+ (- n m) 1) (length ms))))-                                         $ts>>]-                            (fn-s opts' {@hs @(map (lambda [$m] (S.concat {"\"" m "\""})) ms) @ts})]-                           [[<cons <cons $m <cons _ <nil>>> $opts'>-                             _]-                            (fn-s {{m} @opts'} fs)]-                           [[_ _] fs]-                           })]-                 [$fn-c (match-lambda [(list (list integer)) (list string)]-                          {[[<nil> $fs] fs]-                           [[<cons <cons $m <nil>> $opts'>-                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))-                                   <cons $mf <nil>>>]-                            (fn-c opts' {@hs (S.concat {"{" mf "}"})})]-                           [[<cons <cons $m <nil>> $opts'>-                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))-                                   <cons $mf <snoc $tf $ms>>>]-                            (fn-c opts' {@hs (S.append "{" mf) @ms (S.append tf "}")})]-                           [[<cons <cons $m <cons ,m <nil>>> $opts'>-                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))-                                   <cons $mf $ts>>]-                            (fn-c opts' {@hs (S.concat {"{" mf "}"}) @ts})]-                           [[<cons <cons $m <cons $n <nil>>> $opts'>-                             <join (& $hs ?(lambda [$hs] (eq? (- m 1) (length hs))))-                                   <cons $mf <join (& $ms ?(lambda [$ms] (eq? (- n m 1) (length ms))))-                                                   <cons $nf $ts>>>>]-                            (fn-c opts' {@hs (S.append "{" mf) @ms (S.append nf "}") @ts})]-                           [[<cons <cons $m <cons _ <nil>>> $opts'>-                             _]-                            (fn-c {{m} @opts'} fs)]-                           [[_ _] fs]-                           })]}-          (return (read-tsv (S.intercalate "\t" (fn-c copts (fn-s sopts fs))))))))))+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)))) -(define $TSV.show show-tsv)+TSV.show := showTsv
lib/core/string.egi view
@@ -1,128 +1,84 @@-;;;;;-;;;;;-;;;;; S.ring-;;;;;-;;;;;--(define $string-  (matcher-    {[<regex-cg ,$regexpr $ $ $> [string (list string) string]-      {[$tgt (regex-cg regexpr tgt)]}]-     [<regex ,$regexpr $ $ $> [string string string]-      {[$tgt (regex regexpr tgt)]}]-     [<nil> []-      {[$tgt (if (eq? "" tgt)-               {[]}-               {})]}]-     [<cons $ $> [char string]-      {[$tgt (if (eq? "" tgt)-               {}-               {(uncons-string tgt)})]}]-     [<join $ <cons ,$px $>> [string string]-      {[$tgt (match-all (S.split (pack {px}) tgt) (list string)-               [<join (& !<nil> $xs) (& !<nil> $ys)> [(S.intercalate (pack {px}) xs)-                                (S.intercalate (pack {px}) ys)-                                ]])]}]-     [<join $ <join ,$pxs $>> [string string]-      {[$tgt (match-all (S.split pxs tgt) (list string)-               [<join (& !<nil> $xs) (& !<nil> $ys)> [(S.intercalate pxs xs)-                                (S.intercalate pxs ys)-                                ]])]}]-     [<join $ $> [string string]-      {[$tgt (match-all tgt string-                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(pack (map (lambda [$i] xa_i) (between 1 n))) rs]])]}]-     [,$val []-      {[$tgt  (if (eq? val tgt)-                {[]}-                {})]}]-     [$ [something]-      {[$tgt {tgt}]}]-     }))+--+--+-- String+--+-- -;;;-;;; S.ring as collection-;;;-(define $S.empty?-  (lambda [$xs]-    (eq? xs "")))+string :=+  matcher+    | regexCg #$regexpr $ $ $ as (string, list string, string) with+      | $tgt -> regexCg regexpr tgt+    | regex #$regexpr $ $ $ as (string, string, string) with+      | $tgt -> regex regexpr tgt+    | [] as () with+      | $tgt -> if "" = tgt then [()] else []+    | $ :: $ as (char, string) with+      | $tgt -> if "" = tgt then [] else [unconsString tgt]+    | $ ++ #$px :: $ as (string, string) with+      | $tgt ->+        matchAll S.split (pack [px]) tgt as list string with+          | (![] & $xs) ++ ![] & $ys ->+            (S.intercalate (pack [px]) xs, S.intercalate (pack [px]) ys)+    | $ ++ #$pxs ++ $ as (string, string) with+      | $tgt ->+        matchAll S.split pxs tgt as list string with+          | (![] & $xs) ++ ![] & $ys ->+            (S.intercalate pxs xs, S.intercalate pxs ys)+    | $ ++ $ as (string, string) with+      | $tgt ->+        matchAll tgt as string with+          | loop $i (1, $n)+              ($xa_i :: ...)+              $rs -> (pack (map (\i -> xa_i) (between 1 n)), rs)+    | #$val as () with+      | $tgt -> if val = tgt then [()] else []+    | $ as (something) with+      | $tgt -> [tgt] -(define $S.cons-  (lambda [$x $xs]-    (append-string (pack {x}) xs)))+--+-- String as collection+--+S.isEmpty xs := xs = "" -(define $S.car-  (lambda [$xs]-    (match xs string-      {[<cons $x _> x]})))+S.cons x xs := appendString (pack [x]) xs -(define $S.cdr-  (lambda [$xs]-    (match xs string-      {[<cons _ $r> r]})))+S.head xs :=+  match xs as string with+    | $x :: _ -> x -(define $S.rac-  (lambda [$str]-    (match str string-      {[<join _ <cons $c <nil>>> c]})))+S.tail xs :=+  match xs as string with+    | _ :: $r -> r -(define $S.map-  (lambda [$f $xs]-    (pack (map f (unpack xs)))))+S.last str :=+  match str as string with+    | _ ++ $c :: [] -> c -(define $S.length-  (lambda [$xs]-    (length-string xs)))+S.map f xs := pack (map f (unpack xs)) -(define $S.split-  (lambda [$in $ls]-    (split-string in ls)))+S.length xs := lengthString xs -(define $S.append-  (lambda [$xs $ys]-    (append-string xs ys)))+S.split sep ls := splitString sep ls -(define $S.concat-  (lambda [$xss]-    (foldr (lambda [$xs $rs] (S.append xs rs))-           ""-           xss)))+S.append xs ys := appendString xs ys -(define $S.intercalate (compose intersperse S.concat))+S.concat xss := foldr (\xs rs -> S.append xs rs) "" xss -(define $S.replace-  (lambda [$before $after $str]-    (S.intercalate after (S.split before str))))+S.intercalate := compose intersperse S.concat +S.replace before after str := S.intercalate after (S.split before str) -;;-;; Alphabet-;;-(define $C.between-  (lambda [$c1 $c2]-    (map itoc (between (ctoi c1) (ctoi c2)))))+--+-- Alphabet+--+C.between c1 c2 := map itoc (between (ctoi c1) (ctoi c2)) -(define $C.between?-  (lambda [$c1 $c2 $c]-    (and (gte? (ctoi c) (ctoi c1))-         (lte? (ctoi c) (ctoi c2)))))+C.isBetween c1 c2 c := ctoi c >= ctoi c1 && ctoi c <= ctoi c2 -(define $alphabet?-  (lambda [$c]-    (or (C.between? c#a c#z c)-        (C.between? c#A c#Z c))))+isAlphabet c := C.isBetween 'a' 'z' c || C.isBetween 'A' 'Z' c -(define $alphabets?-  (lambda [$s]-    (all alphabet? (unpack s))))+isAlphabetString s := all isAlphabet (unpack s) -(define $upper-case-  (lambda [$c]-    (if (C.between? c#a c#z c)-      (itoc (- (ctoi c) 32))-      c)))+upperCase c := if C.isBetween 'a' 'z' c then itoc (ctoi c - 32) else c -(define $lower-case-  (lambda [$c]-    (if (C.between? c#A c#Z c)-      (itoc (+ (ctoi c) 32))-      c)))+lowerCase c := if C.isBetween 'A' 'Z' c then itoc (ctoi c + 32) else c
lib/math/algebra/equations.egi view
@@ -1,62 +1,52 @@-;;;;;-;;;;;-;;;;; Equations-;;;;;-;;;;;+--+--+-- Equations+--+-- -(define $solve1-  (lambda [$f $expr $x]-    (inverse expr f x)))+solve1 f expr x := inverse expr f x -(define $solve-  (lambda [$eqs]-    (solve' eqs {})))+solve eqs := solve' eqs [] -(define $solve'-  (lambda [$eqs $rets]-    (match eqs (list [math-expr math-expr symbol-expr])-      {[<nil> rets]-       [<cons [$f $expr $x] $rs>-        (solve' rs {@rets [x (solve1 (substitute rets f) (substitute rets expr) x)]})]})))+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-;;;-(define $quadratic-formula q-f)+--+-- Quadratic Equations+--+quadraticFormula := qF -(define $q-f-  (lambda [$f $x]-    (match (coefficients f x) (list math-expr)-      {[<cons $a_0 <cons $a_1 <cons $a_2 <nil>>>>-        (q-f' a_2 a_1 a_0)]})))+qF f x :=+  match coefficients f x as list mathExpr with+    | $a_0 :: $a_1 :: $a_2 :: [] -> qF' a_2 a_1 a_0 -(define $q-f'-  (lambda [$a $b $c]-    [(/ (+ (* -1 b) (sqrt (- (** b 2) (* 4 a c)))) (* 2 a))-     (/ (- (* -1 b) (sqrt (- (** b 2) (* 4 a c)))) (* 2 a))]))+qF' a b c :=+  ( ((- b) + sqrt (b ^ 2 - 4 * a * c)) / 2 * a+  , ((- b) - sqrt (b ^ 2 - 4 * a * c)) / 2 * a ) -;;;-;;; Cubic Equations-;;;-(define $cubic-formula c-f)+--+-- Cubic Equations+--+cubicFormula := cF -(define $c-f-  (lambda [$f $x]-    (match (coefficients f x) (list math-expr)-      {[<cons $a_0 <cons $a_1 <cons $a_2 <cons $a_3 <nil>>>>>-        (c-f' a_3 a_2 a_1 a_0)]})))+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 -(define $c-f'-  (lambda [$a $b $c $d]-    (match [a b c d] [math-expr math-expr math-expr math-expr]-      {[[,1 ,0 $p $q]-        (let* {[[$s1 $s2] (2#[(rt 3 %1) (rt 3 %2)] (q-f' 1 (* 27 q) (* -27 p^3)))]}-          [(/ (+ s1 s2) 3)               ; r1-           (/ (+ (* w^2 s1) (* w s2)) 3) ; r2-           (/ (+ (* w s1) (* w^2 s2)) 3) ; r3-           ])]-       [[,1 _ _ _]-        (3#[(- %1 (/ b 3)) (- %2 (/ b 3)) (- %3 (/ b 3))]-           (with-symbols {x y}-             (c-f (substitute {[x (- y (/ b 3))]} (+ x^3 (* b x^2) (* c x) d)) y)))]-       [[_ _ _ _] (c-f' 1 (/ b a) (/ c a) (/ d a))]})))+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))+       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)+    | (_, _, _, _) -> cF' 1 (b / a) (c / a) (d / a)
lib/math/algebra/inverse.egi view
@@ -1,46 +1,34 @@-;;;;;-;;;;; Inverse-;;;;;--(inverse (f x) x)-(f~-1 x)--(inverse (** x 2) x)-;(sqrt x)--; (inverse t (* a x^2) x)-; t = (* a x^2)-; x = (sqrt (/ t a))+--+-- Inverse+-- -(define $inverse-  (lambda [$t $f $x]-    (match f math-expr-      {[?simple-term?-        (match f symbol-expr-          {[,x t]-           [(,exp ,x) (log t)]-           [(,log ,x) (exp t)]-           [(,sqrt ,x) (** t 2)]-           [(,cos ,x) (acos t)]-           [(,sin ,x) (asin t)]-           [(,acos ,x) (cos t)]-           [(,asin ,x) (sin t)]-           [_ (inverse' t f x)]-           })]-       [?term?-        (match f term-expr-          {[<term ,1 <ncons $n ,x <nil>>> (rt n t)]-           [<term _ <ncons $n ,x _>>-            (let {[$a (/ f (** x n))]}-              (inverse (/ t a) (/ f a) x))]-           [_ (`inverse t f x)]})]-       [?polynomial?-        (match (coefficients x f) (list math-expr)-          {[<cons $c (loop $i [1 $n] <cons ,0 ...> <cons $a <nil>>)>-            (inverse (/ (- t c) a) (** x (+ n 1)) x)]-           [_ (`inverse t f x)]})]-       [_-        (match f math-expr-          {[<div $p1 $p2>-            (inverse (* p2 t) p1 x)]})]-       [_ (`inverse t f x)]})))+inverse t f x :=+  match f as mathExpr with+    | ?isSimpleTerm ->+      match f as symbolExpr with+        | #x -> t+        | #exp #x -> log t+        | #log #x -> exp t+        | #sqrt #x -> t ^ 2+        | #cos #x -> acos t+        | #sin #x -> asin t+        | #acos #x -> cos t+        | #asin #x -> sin t+        | _ -> inverse' t f x  -- TODO: define inverse'+    | ?isTerm ->+      match f as termExpr with+        | term #1 (ncons $n #x []) -> rt n t+        | term _ (ncons $n #x _) ->+          let a := f / x ^ n+           in inverse (t / a) (f / a) x+        | _ -> `inverse t f x+    | ?isPolynomial ->+      match coefficients x f as list mathExpr with+        | $c :: (loop $i (1, $n)+                   (#0 :: ...)+                   ($a :: [])) -> inverse ((t - c) / a) (x ^ (n + 1)) x+        | _ -> `inverse t f x+    | _ ->+      match f as mathExpr with+        | $p1 / $p2 -> inverse (p2 * t) p1 x+    | _ -> `inverse t f x
lib/math/algebra/matrix.egi view
@@ -1,205 +1,197 @@-;;-;; Matrices-;;--(define $M.*-  (cambda $ms-    (foldl M.b.* (car ms) (cdr ms))))--(define $M.b.*-  (lambda [%m1 %m2]-    (with-symbols {j}-      (. m1~#~j m2_j_#))))--(define $M.*'-  (cambda $ms-    (foldl M.b.*' (car ms) (cdr ms))))--(define $M.b.*'-  (lambda [%m1 %m2]-    (with-symbols {j}-      (.' m1~#~j m2_j))))--(define $M.power-  (lambda [%m $n]-    (repeated-squaring M.* m n)))--(define $M.comm-  (lambda [%m1 %m2]-    (with-symbols {i j k}-      (- (. m1~i~j m2_j_k) (. m2~i~j m1_j_k)))))--(define $M.inverse-  (lambda [%m]-    (let {[$d (M.det m)]}-      (generate-tensor-        2#(match m matrix-            {[<cons ,%2 ,%1 _ $A $B $C $D>-              (if (even? (+ %1 %2))-                (/ (M.det (M.join A B C D)) d)-                (* -1 (/ (M.det (M.join A B C D)) d)))]})-        (tensor-shape m)))))+--+-- Matrices+-- -(define $trace (lambda [%t] (with-symbols {i} (contract + t~i_i))))+M.* %s %t := withSymbols [i, j, k] s~i~j . t_j+M.*' %s %t := withSymbols [i, j, k] s~i~j .' t_j -(define $matrix-  (matcher-    {[<quad-cons $ $ $ $> [math-expr matrix matrix matrix]-      {[$tgt (match (tensor-shape tgt) (list integer)-               {[<cons $m <cons $n _>>-                 {[tgt_1_1 tgt_1_[2 n] tgt_[2 m]_1 tgt_[2 m]_[2 n]]}]-                [_ {}]})]}]-     [<cons ,$i ,$j $ $ $ $ $> [math-expr matrix matrix matrix matrix]-      {[$tgt-        (let* {[$ns (tensor-shape tgt)]-               [$m (nth 1 ns)]-               [$n (nth 2 ns)]}-          {[tgt_i_j-            tgt_[1 (- i 1)]_[1 (- j 1)]-            tgt_[1 (- i 1)]_[(+ j 1) n]-            tgt_[(+ i 1) m]_[1 (- j 1)]-            tgt_[(+ i 1) m]_[(+ j 1) n]-            ]})]}]-     [,$val []-      {[$tgt (if (eq? val tgt) {[]} {})]}]-     [$ [something]-      {[$tgt {tgt}]}]-     }))+M.power %t n := foldl M.* t (take (n - 1) (repeat1 t))+--M.power %m n := repeatedSquaring M.* m n -(define $M.join-  (lambda [%A %B %C %D]-    (let* {[$as (tensor-shape A)]-           [$a1 (nth 1 as)] [$a2 (nth 2 as)]-           [$bs (tensor-shape B)]-           [$b1 (nth 1 bs)] [$b2 (nth 2 bs)]-           [$cs (tensor-shape C)]-           [$c1 (nth 1 cs)] [$c2 (nth 2 cs)]-           [$ds (tensor-shape D)]-           [$d1 (nth 1 ds)] [$d2 (nth 2 ds)]-           [$m1 (max {a1 b1})] [$m2 (max {a2 c2})]-           [$n1 (max {c1 d1})] [$n2 (max {b2 d2})]-           }-      (generate-tensor-        2#(match [%1 %2] [integer integer]-            {[[?(lte? $ a1) ?(lte? $ a2)] A_%1_%2]-             [[?(lte? $ m1) _] B_%1_(- %2 a2)]-             [[_ ?(lte? $ m2)] C_(- %1 a1)_%2]-             [[_ _] D_(- %1 m1)_(- %2 m2)]})-        {(+ m1 n1) (+ m2 n2)}))))+M.comm %m1 %m2 := withSymbols [i, j, k] m1~i~j . m2_j_k - m2~i~j . m1_j_k -;;-;; Determinant-;;+M.inverse %m :=+  let d := M.det m+   in generateTensor+        2#(match m as matrix with+          | cons #%2 #%1 _ $A $B $C $D ->+            if isEven (%1 + %2)+              then M.det (M.join A B C D) / d+              else - (M.det (M.join A B C D) / d))+        (tensorShape m) -(define $even-and-odd-permutations-  (lambda [$n]-    (let {[[$es $os] (even-and-odd-permutations' n)]}-      [(map 1#(lambda [$i] (nth i %1)) es)-       (map 1#(lambda [$i] (nth i %1)) os)])))+trace %t := withSymbols [i] sum (contract t~i_i) -(define $even-and-odd-permutations0-  (lambda [$n]-    (let {[[$es $os] (even-and-odd-permutations' n)]}-      [(map 1#(lambda [$i] (nth (+ i 1) (map (- $ 1) %1))) es)-       (map 1#(lambda [$i] (nth (+ i 1) (map (- $ 1) %1))) os)])))+matrix :=+  matcher+    | quadCons $ $ $ $ as (mathExpr, matrix, matrix, matrix) with+      | $tgt ->+        match tensorShape tgt as list integer with+          | $m :: $n :: _ ->+            [(tgt_1_1, tgt_1_(2, n), tgt_(2, m)_1, tgt_(2, m)_(2, n))]+          | _ -> []+    | cons #$i #$j $ $ $ $ $ as (mathExpr, matrix, matrix, matrix, matrix) with+      | $tgt ->+        let ns := tensorShape tgt+            m := nth 1 ns+            n := nth 2 ns+         in [ ( tgt_i_j+            , tgt_(1, i - 1)_(1, j - 1)+            , tgt_(1, i - 1)_(j + 1, n)+            , tgt_(i + 1, m)_(1, j - 1)+            , tgt_(i + 1, m)_(j + 1, n) ) ]+    | #$val as () with+      | $tgt -> if val = tgt then [()] else []+    | $ as (something) with+      | $tgt -> [tgt] -(define $even-and-odd-permutations'-  (lambda [$n]-    (match n integer-      {[,1 [{{1}} {}]]-       [,2 [{{1 2}} {{2 1}}]]-       [_ (let* {[[$es $os] (even-and-odd-permutations' (- n 1))]-                 [$es' (map 1#{@%1 n} es)]-                 [$os' (map 1#{@%1 n} os)]}-            [{@es'-              @(concat (map (lambda [$i] (map (permutate i n $) os')) (between 1 (- n 1))))-              }-             {@os'-              @(concat (map (lambda [$i] (map (permutate i n $) es')) (between 1 (- n 1))))-              }-             ]-            )]})))+M.join %A %B %C %D :=+  let ashape := tensorShape A+      a1 := nth 1 ashape+      a2 := nth 2 ashape+      bshape := tensorShape B+      b1 := nth 1 bshape+      b2 := nth 2 bshape+      cshape := tensorShape C+      c1 := nth 1 cshape+      c2 := nth 2 cshape+      dshape := tensorShape D+      d1 := nth 1 dshape+      d2 := nth 2 dshape+      m1 := max a1 b1+      m2 := max a2 c2+      n1 := max c1 d1+      n2 := max b2 d2+   in generateTensor+        2#(match (%1, %2) as (integer, integer) with+          | (?(<= a1), ?(<= a2)) -> A_%1_%2+          | (?(<= m1), _) -> B_%1_(%2 - a2)+          | (_, ?(<= m2)) -> C_(%1 - a1)_%2+          | (_, _) -> D_(%1 - m1)_(%2 - m2))+        [m1 + n1, m2 + n2] -(define $permutate-  (lambda [$x $y $xs]-    (match xs (list eq)-      {[<join $hs <cons ,x <join $ms <cons ,y $ts>>>>-        {@hs y @ms x @ts}]-       [<join $hs <cons ,y <join $ms <cons ,x $ts>>>>-        {@hs x @ms y @ts}]})))+--+-- Determinant+--+evenAndOddPermutations n :=+  let (es, os) := evenAndOddPermutations' n+   in (map 1#(\i -> nth i %1) es, map 1#(\i -> nth i %1) os) -(define $M.determinant-  (lambda [%m]-    (match (tensor-shape m) (list integer)-      {[<cons ,0 <cons ,0 <nil>>> 1]-       [<cons $n <cons ,n <nil>>>-        (let {[[$es $os] (even-and-odd-permutations' n)]}-          (- (sum (map (lambda [$e]-                         (product (map2 (lambda [$i $j] m_i_j)-                                        (between 1 n)-                                        e)))-                       es))-             (sum (map (lambda [$o]-                         (product (map2 (lambda [$i $j] m_i_j)-                                        (between 1 n)-                                        o)))-                       os))))]-       [_ undefined]})))+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 ) -(define $M.det M.determinant)+evenAndOddPermutations' n :=+  match n as integer with+    | #1 -> ([[1]], [])+    | #2 -> ([[1, 2]], [[2, 1]])+    | _ ->+      let (es, os) := evenAndOddPermutations' (n - 1)+          es' := map (++ [n]) es+          os' := map (++ [n]) os+       in ( es' ++ concat+                     (map+                        (\i -> map 1#(permutate i n %1) os')+                        (between 1 (n - 1)))+          , os' ++ concat+                     (map+                        (\i -> map 1#(permutate i n %1) es')+                        (between 1 (n - 1))) ) -;;;-;;; Eigenvalues and eigenvectors-;;;+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 -(define $M.eigenvalues-  (lambda [%m]-    (match (tensor-shape m) (list integer)-      {[<cons ,2 <cons ,2 <nil>>>-        (let {[[$e1 $e2] (q-f (M.det (T.- m (scalar-to-tensor x {2 2}))) x)]}-          {e1 e2})]-       [_ undefined]})))+M.determinant %m :=+  match tensorShape m as list integer with+    | #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)+    | _ -> undefined -(define $M.eigenvectors-  (lambda [%m]-    (match (tensor-shape m) (list integer)-      {[<cons ,2 <cons ,2 <nil>>>-        (let {[[$e1 $e2] (q-f (M.det (T.- m (scalar-to-tensor x {2 2}))) x)]}-          {[e1 (clear-index (T.- m (scalar-to-tensor e1 {2 2}))_i_1)]-           [e2 (clear-index (T.- m (scalar-to-tensor e2 {2 2}))_i_1)]})-        ]-       [_ undefined]})))+M.det := M.determinant -;;-;; LU decomposition-;;+--+-- Eigenvalues and eigenvectors+--+M.eigenvalues %m :=+  match tensorShape m as list integer with+    | #2 :: #2 :: [] ->+      let (e1, e2) := qF (M.det (T.- m (scalarToTensor x [2, 2]))) x+       in [e1, e2]+    | _ -> undefined -(define $M.LU-  (lambda [%x]-    (match (tensor-shape x) (list integer)-      {[<cons ,2 <cons ,2 <nil>>>-        (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[<less> 0] [<equal> 1] [<greater> b_%1_%2]}) {2 2})]-               [$U (generate-tensor 2#(match (compare %1 %2) ordering {[<greater> 0] [_ c_%1_%2]}) {2 2})]-               [$m (M.* L U)]-               [$ret (solve {[m_1_1 x_1_1 c_1_1] [m_1_2 x_1_2 c_1_2]-                             [m_2_1 x_2_1 b_2_1] [m_2_2 x_2_2 c_2_2]})]}-          [(substitute ret L) (substitute ret U)])]-       [<cons ,3 <cons ,3 <nil>>>-        (let* {[$L (generate-tensor 2#(match (compare %1 %2) ordering {[<less> 0] [<equal> 1] [<greater> b_%1_%2]}) {3 3})]-               [$U (generate-tensor 2#(match (compare %1 %2) ordering {[<greater> 0] [_ c_%1_%2]}) {3 3})]-               [$m (M.* L U)]-               [$ret (solve {[m_1_1 x_1_1 c_1_1] [m_1_2 x_1_2 c_1_2] [m_1_3 x_1_3 c_1_3]-                             [m_2_1 x_2_1 b_2_1] [m_2_2 x_2_2 c_2_2] [m_2_3 x_2_3 c_2_3]-                             [m_3_1 x_3_1 b_3_1] [m_3_2 x_3_2 b_3_2] [m_3_3 x_3_3 c_3_3]})]}-          [(substitute ret L) (substitute ret U)])]-       [_ undefined]})))+M.eigenvectors %m :=+  match tensorShape m as list integer with+    | #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) ]+    | _ -> undefined -;;-;; Utility-;;+--+-- LU decomposition+--+M.LU %x :=+  match tensorShape x as list integer with+    | #2 :: #2 :: [] ->+      let L := generateTensor+                 2#(match compare %1 %2 as ordering with+                   | less -> 0+                   | equal -> 1+                   | greater -> b_%1_%2)+                 [2, 2]+          U := generateTensor+                 2#(match compare %1 %2 as ordering with+                   | greater -> 0+                   | _ -> c_%1_%2)+                 [2, 2]+          m := M.* L U+          ret := solve+                   [ (m_1_1, x_1_1, c_1_1)+                   , (m_1_2, x_1_2, c_1_2)+                   , (m_2_1, x_2_1, b_2_1)+                   , (m_2_2, x_2_2, c_2_2) ]+       in (substitute ret L, substitute ret U)+    | #3 :: #3 :: [] ->+      let L := generateTensor+                 2#(match compare %1 %2 as ordering with+                   | less -> 0+                   | equal -> 1+                   | greater -> b_%1_%2)+                 [3, 3]+          U := generateTensor+                 2#(match compare %1 %2 as ordering with+                   | greater -> 0+                   | _ -> c_%1_%2)+                 [3, 3]+          m := M.* L U+          ret := solve+                   [ (m_1_1, x_1_1, c_1_1)+                   , (m_1_2, x_1_2, c_1_2)+                   , (m_1_3, x_1_3, c_1_3)+                   , (m_2_1, x_2_1, b_2_1)+                   , (m_2_2, x_2_2, c_2_2)+                   , (m_2_3, x_2_3, c_2_3)+                   , (m_3_1, x_3_1, b_3_1)+                   , (m_3_2, x_3_2, b_3_2)+                   , (m_3_3, x_3_3, c_3_3) ]+       in (substitute ret L, substitute ret U)+    | _ -> undefined -(define $generate-matrix-from-quadratic-expr-  (lambda [$f $xs]-    (generate-tensor-      2#(coefficient2 f (nth %1 xs) (nth %2 xs))-      {(length xs) (length xs)})))+--+-- Utility+--+generateMatrixFromQuadraticExpr f xs :=+  generateTensor+    2#(coefficient2 f (nth %1 xs) (nth %2 xs))+    [length xs, length xs]
lib/math/algebra/root.egi view
@@ -1,106 +1,87 @@-;;;;;-;;;;;-;;;;; Algebra-;;;;;-;;;;;--;;;-;;; Root-;;;+--+--+-- Algebra+--+-- -(define $rt-  (lambda [$n $x]-    (if (integer? n)-      (match x math-expr-        {[,0 0]-         [?monomial? (rt-monomial n x)]-         [<div <poly $xs> <poly $ys>>-          (let {[$xd (reduce gcd xs)]-                [$yd (reduce gcd ys)]}-            (let {[$d (rt-monomial n (/ xd yd))]}-              (*' d-                 (rt'' n (*' (/' (sum' (map (/' $ xd) xs)) (sum' (map (/' $ yd) ys)))))-                 )))]-         [_ (rt'' n x)]})-      (rt'' n x))))+--+-- Root+--+rt n x :=+  if isInteger n+    then match x as mathExpr with+      | #0 -> 0+      | ?isMonomial -> rtMonomial n x+      | (poly $xs) / (poly $ys) ->+        let xd := reduce gcd xs+            yd := reduce gcd ys+            d := rtMonomial n (xd / yd)+         in d *' rt'' n (sum' (map (/' xd) xs) /' sum' (map (/' yd) ys))+      | _ -> rt'' n x+    else rt'' n x -(define $rt-monomial-  (lambda [$n $x]-    (/ (rt-term n (* (numerator x)-                     (** (denominator x) (- n 1))))-       (denominator x))))+rtMonomial n x :=+  rtTerm n (numerator x * denominator x ^ (n - 1)) / denominator x -(define $rt-term-  (lambda [$n $x]-    (match x term-expr-      {[<term $a _>-        (if (lt? a 0)-          (*' (rtm1 n) (rt-positive-term n (* -1 x)))-          (rt-positive-term n x))]})))+rtTerm n x :=+  match x as termExpr with+    | term $a _ ->+      if a < 0 then rtm1 n *' rtPositiveTerm n (- x) else rtPositiveTerm n x -(define $rt-positive-term-  (lambda [$n $x]-    (match [n x] [math-expr math-expr]-      {[[,3 (* $a ,i $r)] (* -1 i (rt 3 (*' a r)))]-       [[_ (* $a (,sqrt $b) $r)] (*' (rt (* n 2) (*' (**' a 2) b)) (rt n r))]-       [[_ (* $a (,rt $n' $b) $r)] (*' (rt (* n n') (*' (**' a n') b)) (rt n r))]-       [[_ _] (rt-positive-term1 n x)]-       })))+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 -(define $rt-positive-term1-  (lambda [$n $x]-    (letrec {[$f (lambda [$xs]-                   (match xs (assoc-multiset math-expr)-                     {[<nil> [1 1]]-                      [<ncons $p $k $rs>-                       (let {[[$a $b] (f rs)]}-                         [(*' (**' p (quotient k n)) a) (*' (**' p (remainder k n)) b)])]}))]-             [$g (lambda [$n $x]-                   (let {[$d (match x term-expr-                               {[<term $m $xs> (gcd n (reduce gcd (map 2#%2 {@(to-assoc (p-f m)) @xs})))]})]}-                     (rt'' (/ n d) (rt d x))))]}-      (match x term-expr-        {[<term $m $xs>-          (match (f {@(to-assoc (p-f (abs m))) @xs}) [integer integer]-            {[[$a ,1] a]-             [[$a $b] (*' a (g n b))]})]}))))+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 -(define $rt''-  (lambda [$n $x]-    (match [n x] [integer integer]-      {[[,2 _] (`sqrt x)]-       [[_ _] (`rt n x)]})))+rt'' n x :=+  match (n, x) as (integer, integer) with+    | (#2, _) -> `sqrt x+    | (_, _) -> `rt n x -(define $rtm1-  (lambda [$n]-    (match n integer-      {[,1 -1]-       [,2 i]-       [?odd? -1]-       [_ undefined]})))+rtm1 n :=+  match n as integer with+    | #1 -> -1+    | #2 -> i+    | ?isOdd -> -1+    | _ -> undefined -(define $sqrt-  (lambda [$x]-    (if (scalar? x)-      (let {[$m (numerator x)]-            [$n (denominator x)]}-        (/ (rt 2 (* m n)) n))-      (b.sqrt x))))+sqrt x :=+  if isScalar x+    then let m := numerator x+             n := denominator x+          in rt 2 (m * n) / n+    else b.sqrt x -(define $rt-of-unity rtu)+rtOfUnity := rtu -(define $rtu-  (lambda [$n]-    (rtu' n)))+rtu n := rtu' n -(define $rtu'-  (lambda [$n]-    (if (integer? n)-      (match n integer-        {[,1 1]-         [,2 -1]-         [,3 w]-         [,4 i]-         [_ (`rtu n)]-         })-      (`rtu n))))+rtu' n :=+  if isInteger n+    then match n as integer with+      | #1 -> 1+      | #2 -> -1+      | #3 -> w+      | #4 -> i+      | _ -> `rtu n+    else `rtu n
lib/math/algebra/tensor.egi view
@@ -1,43 +1,17 @@-;;;;;-;;;;;-;;;;; Tensor-;;;;;-;;;;;--(define $tensor-order-  (lambda [%A]-    (length (tensor-shape A))))--(define $unit-tensor-  (lambda [$ns]-    (generate-tensor kronecker-delta ns)))--(define $scalar-to-tensor-  (lambda [$x $ns]-    (* x (unit-tensor ns))))--(define $zero-tensor-  (lambda [$ns]-    (generate-tensor (cambda $xs 0) ns)))+--+--+-- Tensor+--+-- -(define $b..' (lambda [%t1 %t2] (contract +' (*' t1 t2))))-(define $b.. (lambda [%t1 %t2] (contract + (* t1 t2))))+tensorOrder %A := length (tensorShape A) -(define $.' (cambda $xs (foldl b..' (car xs) (cdr xs))))+unitTensor ns := generateTensor kroneckerDelta ns -(define $.-  (cambda $xs-    (match xs (list something)-      {;[<join _ <cons (& ?scalar? ?tensor-symbol?) _>> (capply `. xs)]-       [_ (foldl b.. (car xs) (cdr xs))]})))+scalarToTensor x ns := x * unitTensor ns -(define $T.+-  (lambda [%t1 %t2]-    (tensor (tensor-shape t1)-            (map2 + (tensor-to-list t1) (tensor-to-list t2)))))+zeroTensor ns := generateTensor (cambda xs -> 0) ns +(.') %t1 %t2 := sum' (contract (t1 *' t2)) -(define $T.--  (lambda [%t1 %t2]-    (tensor (tensor-shape t1)-            (map2 - (tensor-to-list t1) (tensor-to-list t2)))))+(.) %t1 %t2 := sum (contract (t1 * t2))
lib/math/algebra/vector.egi view
@@ -1,28 +1,16 @@-;;-;; Vectors-;;+--+-- Vectors+-- -(define $dot-product-  (lambda [%v1 %v2]-    (with-symbols {i}-      (. v1~i v2_i))))+dotProduct %v1 %v2 := withSymbols [i] v1~i . v2_i -(define $V.* dot-product)+V.* := dotProduct -(define $cross-product/fn-  (lambda [$fn %a %b]-    [|(- (fn a_2 b_3)  (fn a_3 b_2))-      (- (fn a_3 b_1)  (fn a_1 b_3))-      (- (fn a_1 b_2)  (fn a_2 b_1))|]))+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|] -(define $cross-product-  (lambda [%a %b]-    (cross-product/fn * a b)))+crossProduct %a %b := crossProduct/fn (*) a b -(define $div-  (lambda [%A %xs]-    (trace (∇ A xs))))+div %A %xs := trace (∇ A xs) -(define $rot-  (lambda [%A %xs]-    (cross-product/fn ∂/∂ A xs)))+rot %A %xs := crossProduct/fn ∂/∂ A xs
lib/math/analysis/derivative.egi view
@@ -1,87 +1,77 @@-;;;;;-;;;;;-;;;;; Differentiation-;;;;;-;;;;;+--+--+-- Differentiation+--+-- -(define $∂/∂-  (lambda [$f *$x]-    (match f math-expr-      {; symbol-       [,x 1]-       [?symbol? 0]-       ; function expression-       [<func _ $argnames $args _> (sum (map2 (lambda [$s $r] (* (user-refs f {s}) (∂/∂ r x))) argnames args))]-       ; function application-       [(,`exp $g) (* (exp g) (∂/∂ g x))]-       [(,`log $g) (* (/ 1 g) (∂/∂ g x))]-       [(,`sqrt $g) (* (/ 1 (* 2 (sqrt g))) (∂/∂ g x))]-       [(,`** $g $h) (* f (∂/∂ (* (log g) h) x))]-       [(,`cos $g) (* (* -1 (sin g)) (∂/∂ g x))]-       [(,`sin $g) (* (cos g) (∂/∂ g x))]-       [(,`arccos $g) (* (/ 1 (sqrt (- 1 (** g 2)))) (∂/∂ g x))]-       [<apply $g $args>-        (sum (map 2#(* (capply `(user-refs g {%1}) args) (∂/∂ %2 x))-                  (zip nats args)))]-       ; quote-       [<quote $g>-        (let {[$g' (∂/∂ g x)]}-          (if (monomial? g')-            g'-            (let {[$d (capply gcd (from-poly g'))]}-              (*' d '(map-poly (/' $ d) g')))))]-       ; term (constant)-       [,0 0]-       [(* _ ,1) 0]-       ; term (multiplication)-       [(* ,1 $fx^$n) (* n (** fx (- n 1)) (∂/∂ fx x))]-       [(* $a $fx^$n $r)-        (+ (* a (∂/∂ (**' fx n) x) r)-           (* a (**' fx n) (∂/∂ r x)))]-       ; polynomial-       [<poly $ts> (sum (map (∂/∂ $ x) ts))]-       ; quotient-       [(/ $p1 $p2)-        (let {[$p1' (∂/∂ p1 x)]-              [$p2' (∂/∂ p2 x)]}-          (/ (- (* p1' p2) (* p2' p1)) (** p2 2)))]-       })))+∂/∂ $f *x :=+  match f as mathExpr with+    -- symbol+    | #x -> 1+    | ?isSymbol -> 0+    -- function expression+    | func _ $argnames $args _ ->+      sum (map2 (\s r -> (userRefs f [s]) * ∂/∂ r x) argnames args)+    -- function application+    | #`exp $g -> exp g * ∂/∂ g x+    | #`log $g -> 1 / g * ∂/∂ g x+    | #`sqrt $g -> 1 / (2 * sqrt g) * ∂/∂ g x+    | #`(^) $g $h -> f * ∂/∂ (log g * h) x+    | #`cos $g -> (- sin g) * ∂/∂ g x+    | #`sin $g -> cos g * ∂/∂ g x+    | #`arccos $g -> 1 / sqrt (1 - g ^ 2) * ∂/∂ g x+    | apply $g $args ->+      sum (map 2#((capply `(userRefs g [%1]) args) * ∂/∂ %2 x) (zip nats args))+    -- quote+    | quote $g ->+      let g' := ∂/∂ g x+       in if isMonomial g'+            then g'+            else let d := capply gcd (fromPoly g')+                  in d *' '(mapPoly (/' d) g')+    -- term (constant)+    | #0 -> 0+    | _ * #1 -> 0+    -- term (multiplication)+    | #1 * $fx ^ $n -> n * fx ^ (n - 1) * ∂/∂ fx x+    | $a * $fx ^ $n * $r -> a * ∂/∂ (fx ^' n) x * r + a * fx ^' n * ∂/∂ r x+    -- polynomial+    | poly $ts -> sum (map 1#(∂/∂ %1 x) ts)+    -- quotient+    | $p1 / $p2 ->+      let p1' := ∂/∂ p1 x+          p2' := ∂/∂ p2 x+       in (p1' * p2 - p2' * p1) / p2 ^ 2 -(define $d/d ∂/∂)-(define $pd/pd ∂/∂)+d/d := ∂/∂ -(define $∇ ∂/∂)-(define $nabla ∇)+pd/pd := ∂/∂ -(define $grad ∇)+∇ := ∂/∂ -;(define $taylor-expansion-;  (lambda [$f $x $a]-;    (map2 *-;          (map 1#(/ (** (- x a) %1) (fact %1)) nats0)-           ;          (map (substitute {[x a]} $) (iterate (∂/∂ $ x) f)))))+nabla := ∇ -(define $taylor-expansion-  (lambda [$f $x $a]-    (multivariate-taylor-expansion f [| x |] [| a |])))+grad := ∇ -(define $maclaurin-expansion (taylor-expansion $ $ 0))+taylorExpansion $f $x $a := multivariateTaylorExpansion f [|x|] [|a|] -(define $multivariate-taylor-expansion-  (lambda [%f %xs %as]-    (with-symbols {h}-      (let {[$hs (generate-tensor 1#h_%1 (tensor-shape xs))]}-        (map2 *-              (map 1#(/ 1 (fact %1)) nats0)-              (map (compose 1#(V.substitute xs as %1)-                            1#(V.substitute hs (with-symbols {i} (- xs_i as_i)) %1))-                   (iterate (compose 1#(∇ %1 xs) 1#(V.* hs %1)) f)))))))+maclaurinExpansion := 2#(taylorExpansion %1 %2 0) -(define $multivariate-maclaurin-expansion-  (lambda [%f %xs]-    (multivariate-taylor-expansion f xs (tensor-map 1#0 xs))))+multivariateTaylorExpansion $f %xs %ys :=+  withSymbols [h]+    let hs := generateTensor 1#h_%1 (tensorShape xs)+     in map2+          (*)+          (map 1#(1 / fact %1) nats0)+          (map+             (compose+                1#(V.substitute xs ys %1)+                1#(V.substitute hs (withSymbols [i] xs_i - ys_i) %1))+             (iterate (compose 1#(∇ %1 xs) 1#(V.* hs %1)) f)) -(define $add-user-script-  (lambda [$f $i]-    (let {[[$g $is] (decons-user-scripts f)]}-      (append-user-scripts g (sort {@is i})))))+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
@@ -1,53 +1,41 @@-;;;;;-;;;;;-;;;;; Integration-;;;;;-;;;;;+--+--+-- Integration+--+-- -(define $Sd-  (lambda [$x $f]-    (match f math-expr-      {; symbols-       [,x (* (/ 1 2) x^2)]-       [<symbol _ _> (* f x)]-       ; function application-       [(,exp ,x) (exp x)]-       [(,cos ,x) (sin x)]-       [(,sin ,x) (* -1 (cos x))]-       [(,log ,x) (multSd x 1 (log x))]-       [(,** $a ,x) (/ (** a x) (log a))]-       [(,** $a $y) (with-symbols {t}-                      (substitute {[t y]} (Sd t (* (** a t) (d/d (inverse t y x) t)))))]-       [(,Sd $y $g) (`Sd x (`Sd y g))]-       [($f $y) (with-symbols {t}-                  (substitute {[t y]} (Sd t (* (f t) (d/d (inverse t y x) t)))))]-       ; term (constant)-       [,0 0]-       [<term $c <nil>> (* c x)]-       ; term (multiplication)-       [<mult $a <ncons $n ,x $r>>-        (if (contain-symbol? x r)-          (`Sd x f)-          (* (/ a (+ n 1)) (** x (+ n 1)) r))]-       ; polynomial-       [<poly $ts> (sum (map (Sd x $) ts))]-       ; quotient-       [<div <plus $ts> $p2>-        (sum (map 1#(Sd x (/ %1 p2)) ts))]-       [<div $p1 $p2>-        (if (contain-symbol? x p2)-          (`Sd x f)-          (/ (Sd x p1) p2))]-       })))+Sd x f :=+  match f as mathExpr with+    -- symbols+    | #x -> 1 / 2 * x ^ 2+    | symbol _ _ -> f * x+    -- function application+    | #exp #x -> exp x+    | #cos #x -> sin x+    | #sin #x -> - cos x+    | #log #x -> multSd x 1 (log x)+    | #(^) $a #x -> a ^ x / log a+    | #(^) $a $y ->+      withSymbols [t] substitute [(t, y)] (Sd t (a ^ t * d/d (inverse t y x) t))+    | #Sd $y $g -> `Sd x (`Sd y g)+    | $f $y ->+      withSymbols [t] substitute [(t, y)] (Sd t (f t * d/d (inverse t y x) t))+    -- term (constant)+    | #0 -> 0+    | term $c [] -> c * x+    -- term (multiplication)+    | mult $a (ncons $n #x $r) ->+      if containSymbol x r then `Sd x f else a / (n + 1) * x ^ (n + 1) * r+    -- polynomial+    | poly $ts -> sum (map 1#(Sd x %1) ts)+    -- quotient+    | (plus $ts) / $p2 -> sum (map 1#(Sd x (%1 / p2)) ts)+    | $p1 / $p2 -> if containSymbol x p2 then `Sd x f else Sd x p1 / p2 -(define $multSd-  (lambda [$x $f $g]-    (let {[$F (Sd x f)]}-      (- (* F g)-         (Sd x (* F (d/d g x)))))))+multSd x f g :=+  let F := Sd x f+   in F * g - Sd x (F * d/d g x) -(define $dSd-  (lambda [$x $a $b $f]-    (let {[$F (Sd x f)]}-      (- (substitute {[x b]} F)-         (substitute {[x a]} F)))))+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
@@ -1,125 +1,96 @@-;;;;;-;;;;;-;;;;; Arithmetic Operation-;;;;;-;;;;;+--+--+-- Arithmetic Operation+--+-- -(define $to-math-expr (lambda [$arg] (math-normalize1 (to-math-expr' arg))))+toMathExpr arg := mathNormalize (toMathExpr' arg) -(define $+' (cambda $xs (foldl b.+ (car xs) (cdr xs))))-(define $-' (cambda $xs (foldl b.- (car xs) (cdr xs))))-(define $*' (cambda $xs (foldl b.* (car xs) (cdr xs))))-(define $/' b./)+(+') $x $y := b.+ x y -(define $f.+' (cambda $xs (foldl f.+ (car xs) (cdr xs))))-(define $f.-' (cambda $xs (foldl f.- (car xs) (cdr xs))))-(define $f.*' (cambda $xs (foldl f.* (car xs) (cdr xs))))-(define $f./' f./)+(-') $x $y := b.- x y -(define $+-  (cambda $xs (if (capply or (map float? xs))-                  (capply f.+' (map (lambda [$x] (if (float? x) x (itof x))) xs))-                  (math-normalize1 (capply +' xs)))))-(define $--  (cambda $xs (if (capply or (map float? xs))-                  (capply f.-' (map (lambda [$x] (if (float? x) x (itof x))) xs))-                  (math-normalize1 (capply -' xs)))))-(define $*-  (cambda $xs (if (capply or (map float? xs))-                  (capply f.*' (map (lambda [$x] (if (float? x) x (itof x))) xs))-                  (math-normalize1 (capply *' xs)))))-(define $/-  (lambda [$x $y]-    (if (and (float? x) (float? y))-        (f./ x y)-        (if (float? x)-            (f./ x (itof y))-            (if (float? y)-                (f./ (itof x) y)-                (b./ x y))))))+(*') $x $y := b.* x y -(define $reduce-fraction id)+(/') $x $y := b./ x y -(define $sum-  (lambda [$xs]-    (if (empty? xs)-      0-      (capply + xs))))+(+) $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) -(define $sum'-  (lambda [$xs]-    (foldl +' 0 xs)))+(-) $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) -(define $product-  (lambda [$xs]-    (if (empty? xs)-      1-      (capply * xs))))+(*) $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) -(define $product'-  (lambda [$xs]-    (foldl *' 1 xs)))+(/) $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 -(define $power-  (lambda [$x $n]-    (math-normalize1 (power' x n))))+reduceFraction := id -(define $power'-  (lambda [$x $n]-    (foldl *' 1 (take n (repeat1 x)))))+sum xs := foldl (+) 0 xs -(define $**-  (lambda [$x $n]-    (if (eq? x e)-      (exp n)-      (if (rational? n)-        (if (gte? n 0)-          (if (integer? n)-            (power x n)-            (`** x n))-          (/ 1 (** x (neg n))))-        (`** x n)))))+sum' xs := foldl (+') 0 xs -(define $**'-  (lambda [$x $n]-    (if (eq? x e)-      (exp n)-      (if (rational? n)-        (if (gte? n 0)-          (if (integer? n)-            (power' x n)-            (`** x n))-          (/' 1 (**' x (neg n))))-        (`** x n)))))+product xs := foldl (*) 1 xs -(define $gcd-  (cambda $xs-    (foldl b.gcd (car xs) (cdr xs))))+product' xs := foldl (*') 1 xs -(define $gcd'-  (cambda $xs-    (foldl b.gcd' (car xs) (cdr xs))))+power $x $n := mathNormalize (power' x n) -(define $b.gcd-  (lambda [$x $y]-    (match [x y] [term-expr term-expr]-      {[[_ ,0] x]-       [[,0 _] y]-       [[<term $a $xs> <term $b $ys>]-        (*' (b.gcd' (abs a) (abs b)) (foldl *' 1 (map 2#(**' %1 %2) (AC.intersect xs ys))))]})))+power' $x $n := foldl (*') 1 (take n (repeat1 x)) -(define $b.gcd'-  (lambda [$x $y]-    (match [x y] [integer integer]-      {[[_ ,0] x]-       [[,0 _] y]-       [[_ ?(gte? $ x)] (b.gcd' (modulo y x) x)]-       [[_ _] (b.gcd' y x)]})))+(^) $x $n :=+  if x = e+    then exp n+    else if isRational n+      then if n >= 0+        then if isInteger n then power x n else `(^) x n+        else 1 / x ^ neg n+      else `(^) x n -(define $P./-  (lambda [$fx $gx $x]-    (let* {[$as (reverse (coefficients fx x))]-           [$bs (reverse (coefficients gx x))]-           [[$zs $rs] (L./ as bs)]}-      [(sum' (map2 2#(*' %1 (**' x %2)) (reverse zs) nats0))-       (sum' (map2 2#(*' %1 (**' x %2)) (reverse rs) nats0))])))+(^') $x $n :=+  if x = e+    then exp n+    else if isRational n+      then if n >= 0+        then if isInteger n then power' x n else `(^) x n+        else 1 /' x ^' neg n+      else `(^) x n++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 :=+  match (x, y) as (integer, integer) with+    | (_, #0) -> x+    | (#0, _) -> y+    | (_, ?(>= x)) -> gcd' (modulo y x) x+    | (_, _) -> gcd' y x++P./ fx $gx $x :=+  let xs := reverse (coefficients fx x)+      ys := reverse (coefficients gx x)+      (zs, rs) := L./ xs ys+   in ( sum' (map2 2#(%1 *' x ^' %2) (reverse zs) nats0)+      , sum' (map2 2#(%1 *' x ^' %2) (reverse rs) nats0) )
lib/math/common/constants.egi view
@@ -1,9 +1,8 @@-;;;;;-;;;;;-;;;;; Mathematical Constants-;;;;;-;;;;;+--+-- Mathematical constants+-- -(define $pi π)+pi := π -(define $Minkowski-metric [| [| -1 0 0 0 |] [| 0 1 0 0 |] [| 0 0 1 0 |] [| 0 0 0 1 |] |])+MinkowskiMetric :=+  [|[|-1, 0, 0, 0|], [|0, 1, 0, 0|], [|0, 0, 1, 0|], [|0, 0, 0, 1|]|]
lib/math/common/functions.egi view
@@ -1,140 +1,104 @@-;;;;;-;;;;;-;;;;; Mathematical Functions-;;;;;-;;;;;+--+-- Mathematical Functions+-- -(define $abs-  (lambda [$x]-    (if (rational? x)-      (b.abs x)-      x)))+abs $x := if isRational x then b.abs x else x -(define $neg-  (lambda [$x]-    (if (rational? x)-      (b.neg x)-      (* -1 x))))+neg $x := if isRational x then b.neg x else - x -(define $exp-  (lambda [$x]-    (if (float? x)-      (b.exp x)-      (if (term? x)-        (match x term-expr-          {[,0 1]-           [,1 e]-           [<mult $a ,(* i pi)> (** -1 a)]-           [_ (`exp x)]})-        (`exp x)))))+exp $x :=+  if isFloat x+    then b.exp x+    else if isTerm x+      then match x as termExpr with+        | #0 -> 1+        | #1 -> e+        | mult $a #(i * pi) -> (-1) ^ a+        | _ -> `exp x+      else `exp x -(define $log-  (lambda [$x]-    (if (float? x)-      (b.log x)-      (match x math-expr-        {[,1 0]-         [,e 1]-         [_ (`log x)]}))))+log $x :=+  if isFloat x+    then b.log x+    else match x as mathExpr with+      | #1 -> 0+      | #e -> 1+      | _ -> `log x -(define $cos-  (lambda [$x]-    (if (float? x)-      (b.cos x)-      (match x math-expr-        {[,0 1]-         [<term $n <cons ,π <nil>>> (** -1 (abs n))]-         [<div <mult _ ,π> ,2> 0]-         [_ (`cos x)]}))))+cos $x :=+  if isFloat x+    then b.cos x+    else match x as mathExpr with+      | #0 -> 1+      | term $n [#π] -> (-1) ^ abs n+      | (mult _ #π) / #2 -> 0+      | _ -> `cos x -(define $sin-  (lambda [$x]-    (if (float? x)-      (b.sin x)-      (match x math-expr-        {[,0 0]-         [<mult _ ,π> 0]-         [<div <mult $n ,π> ,2> (** -1 (/ (- (abs n) 1) 2))]-         [_ (`sin x)]}))))+sin $x :=+  if isFloat x+    then b.sin x+    else match x as mathExpr with+      | #0 -> 0+      | mult _ #π -> 0+      | (mult $n #π) / #2 -> (-1) ^ ((abs n - 1) / 2)+      | _ -> `sin x -(define $tan-  (lambda [$x]-    (if (float? x)-      (b.tan x)-      (match x math-expr-        {[,0 0]-         [_ (`tan x)]}))))+tan $x :=+  if isFloat x+    then b.tan x+    else match x as mathExpr with+      | #0 -> 0+      | _ -> `tan x -(define $cosh-  (lambda [$x]-    (if (float? x)-      (b.cosh x)-      (match x math-expr-        {[,0 1]-         [_ (`cosh x)]}))))+cosh $x :=+  if isFloat x+    then b.cosh x+    else match x as mathExpr with+      | #0 -> 1+      | _ -> `cosh x -(define $sinh-  (lambda [$x]-    (if (float? x)-      (b.sinh x)-      (match x math-expr-        {[,0 0]-         [_ (`sinh x)]}))))+sinh $x :=+  if isFloat x+    then b.sinh x+    else match x as mathExpr with+      | #0 -> 0+      | _ -> `sinh x -(define $tanh-  (lambda [$x]-    (if (float? x)-      (b.tanh x)-      (match x math-expr-        {[,0 0]-         [_ (`tanh x)]}))))+tanh $x :=+  if isFloat x+    then b.tanh x+    else match x as mathExpr with+      | #0 -> 0+      | _ -> `tanh x -(define $sinc-  (lambda [$x]-    (if (float? x)-      (if (eq? x 0.0)-        1.0-        (/ (b.sin x) x))-      (match x math-expr-        {[,0 1]-         [_ (/ (sin x) x)]}))))+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 -(define $sigmoid-  (lambda [$z]-    (/ 1 (+ 1 (exp (* -1 z))))))+sigmoid $z := 1 / (1 + exp (- z)) -(define $kronecker-delta-  (cambda $js-    (if (all (eq? $ (car js)) (cdr js)) 1 0)))+kroneckerDelta := cambda js -> if all (= head js) (tail js) then 1 else 0 -(define $euler-totient-function-  (lambda [$n]-    (* n-       (product (map (lambda [$p] (- 1 (/ 1 p)))-                     (unique (p-f n)))))))+eulerTotientFunction $n := n * product (map (\p -> 1 - 1 / p) (unique (pF n))) -(define $ε-  (memoized-lambda [$n]-    (let {[[$es $os] (even-and-odd-permutations' n)]}-      (generate-tensor-        (cambda $is-          (if (member? is es)-            1-            (if (member? is os)-              -1-              0)))-        (take n (repeat1 n))))))+ε :=+  memoizedLambda n ->+    let (es, os) := evenAndOddPermutations' n+     in generateTensor+          (cambda is ->+            if member is es then 1 else if member is os then -1 else 0)+          (take n (repeat1 n)) -(define $ε'-  (memoized-lambda [$n $k]-    (let {[[$es $os] (even-and-odd-permutations' n)]}-      (generate-tensor-        (cambda $is-          (match (drop k is) (list integer)-            {[<join _ <cons $x <join _ <cons ?1#(lt? %1 x) _>>>> 0]-             [_ (if (member? is es)-                  1-                  (if (member? is os)-                    -1-                    0))]}))-        (take n (repeat1 n))))))+ε' :=+  memoizedLambda n k ->+    let (es, os) := evenAndOddPermutations' n+     in generateTensor+          (cambda is ->+            match drop k is as list integer with+              | _ ++ $x :: _ ++ ?(< x) :: _ -> 0+              | _ ->+                if member is es then 1 else if member is os then -1 else 0)+          (take n (repeat1 n))
lib/math/expression.egi view
@@ -1,391 +1,366 @@-;;;;;-;;;;;-;;;;; Mathematics Expressions-;;;;;-;;;;;+--+--+-- Mathematics Expressions+--+-- -(define $math-expr-  (matcher-    {[,$val []-      {[$tgt (if (eq? val tgt)-               {[]}-               {})]}]-     [$ [math-expr']-      {[$tgt {(from-math-expr tgt)}]}]-     }))+mathExpr :=+  matcher+    | #$val as () with+      | $tgt -> if val = tgt then [()] else []+    | $ as (mathExpr') with+      | $tgt -> [fromMathExpr tgt] -(define $math-expr'-  (matcher-    {[<div $ $> [math-expr math-expr]-      {[<Div $p1 $p2> {[(to-math-expr' p1) (to-math-expr' p2)]}]-       [_ {}]}]-     [<poly $> [(multiset math-expr)]-      {[<Div <Plus $ts> <Plus {<Term 1 {}> @{}}>> {(map to-math-expr' ts)}]-       [_ {}]}]-     [<plus $> [plus-expr]-      {[<Div <Plus $ts> <Plus {<Term 1 {}> @{}}>> {(to-math-expr' <Div <Plus ts> <Plus {<Term 1 {}>}>>)}]-       [_ {}]}]-     [<term $ $> [integer (assoc-multiset math-expr)]-      {[<Div <Plus {<Term $n $xs> @{}}> <Plus {<Term 1 {}> @{}}>> {[n (map 2#[(to-math-expr' %1) %2] xs)]}]-       [_ {}]}]-     [<mult $ $> [integer mult-expr]-      {[<Div <Plus {<Term $n $xs> @{}}> <Plus {<Term 1 {}> @{}}>> {[n (product' (map 2#(**' (to-math-expr' %1) %2) xs))]}]-       [_ {}]}]-;     [<symbol $> [eq]-;      {[<Div <Plus {<Term 1 {[<Symbol $v {}> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {v}]-;       [_ {}]}]-     [<symbol $ $> [eq (list index-expr)]-      {[<Div <Plus {<Term 1 {[<Symbol $v $js> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {[v js]}]-       [_ {}]}]-     [<apply $ $> [eq (list math-expr)]-      {[<Div <Plus {<Term 1 {[<Apply $v $mexprs> 1] @{}}> @{}}>-             <Plus {<Term 1 {}> @{}}>>-        {[v (map to-math-expr' mexprs)]}]-       [_ {}]}]-     [<quote $> [math-expr]-      {[<Div <Plus {<Term 1 {[<Quote $mexpr> 1] @{}}> @{}}>-             <Plus {<Term 1 {}> @{}}>>-        {(to-math-expr' mexpr)}]-       [_ {}]}]-     [<func $ $ $ $> [math-expr (list math-expr) (list math-expr) (list index-expr)]-      {[<Div <Plus {<Term 1 {[<Function $name $argnames $args $js> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {[name argnames args js]}]-       [_ {}]}]-     [$ [something]-      {[$tgt {(to-math-expr' tgt)}]}]-     }))+mathExpr' :=+  matcher+    | div $ $ 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+      | Div (Plus $ts) (Plus [Term 1 []]) ->+        [toMathExpr' (Div (Plus ts) (Plus [Term 1 []]))]+      | _ -> []+    | term $ $ as (integer, assocMultiset mathExpr) with+      | Div (Plus [Term $n $xs]) (Plus [Term 1 []]) ->+        [(n, map 2#(toMathExpr' %1, %2) xs)]+      | _ -> []+    | mult $ $ as (integer, multExpr) with+      | Div (Plus [Term $n $xs]) (Plus [Term 1 []]) ->+        [(n, product' (map 2#(toMathExpr' %1 ^' %2) xs))]+      | _ -> []+    | symbol $ $ as (eq, list indexExpr) with+      | Div (Plus [Term 1 [(Symbol $v $js, 1)]]) (Plus [Term 1 []]) ->+        [(v, js)]+      | _ -> []+    | apply $ $ as (eq, list mathExpr) with+      | Div (Plus [Term 1 [(Apply $v $mexprs, 1)]]) (Plus [Term 1 []]) ->+        [(v, map toMathExpr' mexprs)]+      | _ -> []+    | quote $ as (mathExpr) with+      | Div (Plus [Term 1 [(Quote $mexpr, 1)]]) (Plus [Term 1 []]) ->+        [toMathExpr' mexpr]+      | _ -> []+    | func $ $ $ $ as+        (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+      | $tgt -> [toMathExpr' tgt] -(define $index-expr-  (algebraic-data-matcher-     {<sub math-expr> <sup math-expr> <user math-expr>}))+indexExpr :=+  algebraicDataMatcher+    | sub mathExpr+    | sup mathExpr+    | user mathExpr -(define $poly-expr math-expr)-(define $term-expr math-expr)-(define $symbol-expr math-expr)+polyExpr := mathExpr -(define $plus-expr-  (matcher-    {[<nil> []-      {[$tgt (if (eq? tgt 0)-               {[]}-               {})]}]-     [<cons $ $> [math-expr plus-expr]-      {[$tgt (match-all tgt math-expr-               [<poly <cons $t $ts>> [t (sum' ts)]])]}]-     [$ [math-expr]-      {[$tgt {tgt}]}]-     }))+termExpr := mathExpr -(define $mult-expr-  (matcher-    {[<nil> []-      {[$tgt (match tgt math-expr-               {[,0 {[]}]-                [_ {}]})]}]-     [<cons $ $> [math-expr mult-expr]-      {[$tgt (match tgt math-expr-               {[<term _ $xs>-                 (match-all xs (assoc-multiset math-expr)-                   [<cons $x $rs>-                    [x (product' (map 2#(**' %1 %2) rs))]])]-                [_ {}]})]}]-     [<ncons $ ,$k $> [math-expr mult-expr]-      {[$tgt (match tgt math-expr-               {[<term _ $xs>-                 (match-all xs (list [math-expr integer])-                   [<join $hs <cons [$x (& ?(gte? $ k) $n)] $ts>>-                    [x (product' (map 2#(**' %1 %2) {@hs [x (- n k)] @ts}))]])]-                [_ {}]})]}]-     [<ncons $ $ $> [math-expr integer mult-expr]-      {[$tgt (match tgt math-expr-               {[<term _ $xs>-                 (match-all xs (list [math-expr integer])-                   [<join $hs <cons [$x $n] $ts>>-                    [x n (product' (map 2#(**' %1 %2) {@hs @ts}))]])]-                [_ {}]})]}]-     [$ [math-expr]-      {[$tgt {tgt}]}]-     }))+symbolExpr := mathExpr -;;-;; Predicate-;;-(define $symbol?-  (lambda [$mexpr]-    (match mexpr math-expr-      {[<symbol _ _> #t]-       [_ #f]})))+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] -(define $tensor-symbol?-  (lambda [$mexpr]-    (match mexpr math-expr-      {[<symbol _ <join _ <cons (| <sub ?symbol?> <sup ?symbol?>) _>>> #t]-       [_ #f]})))+multExpr :=+  matcher+    | [] as () with+      | $tgt ->+        match tgt as mathExpr with+          | #0 -> [()]+          | _ -> []+    | $ :: $ 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+      | $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+      | $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)))+          | _ -> []+    | $ as (mathExpr) with+      | $tgt -> [tgt] -(define $apply?-  (lambda [$mexpr]-    (match mexpr math-expr-      {[<apply _ _> #t]-       [_ #f]})))+isSymbol %mexpr :=+  match mexpr as mathExpr with+    | symbol _ _ -> True+    | _ -> False -(define $simple-term? 1#(or (symbol? %1) (apply? %1)))+isApply %mexpr :=+  match mexpr as mathExpr with+    | apply _ _ -> True+    | _ -> False -(define $term?-  (lambda [$mexpr]-    (match mexpr math-expr-      {[<term _ _> #t]-       [,0 #t]-       [_ #f]})))+isSimpleTerm := 1#(isSymbol %1 || isApply %1) -(define $polynomial?-  (lambda [$mexpr]-    (match mexpr math-expr-      {[<poly _> #t]-       [,0 #t]-       [_ #f]})))+isTerm %mexpr :=+  match mexpr as mathExpr with+    | term _ _ -> True+    | #0 -> True+    | _ -> False -(define $monomial?-  (lambda [$mexpr]-    (match mexpr math-expr-      {[<div <poly <cons <term _ _> <nil>>>-             <poly <cons <term _ _> <nil>>>>-        #t]-       [,0 #t]-       [_ #f]})))+isPolynomial %mexpr :=+  match mexpr as mathExpr with+    | poly _ -> True+    | #0 -> True+    | _ -> False -;;-;; Accessor-;;+isMonomial %mexpr :=+  match mexpr as mathExpr with+    | poly [term _ _] / poly [term _ _] -> True+    | #0 -> True+    | _ -> False -(define $symbol-indices-  (lambda [$mexpr]-    (match mexpr math-expr-      {[<symbol _ $js> js]-       [_ undefined]})))+--+-- Accessor+--+symbolIndices $mexpr :=+  match mexpr as mathExpr with+    | symbol _ $js -> js+    | _ -> undefined -(define $from-monomial-  (lambda [$mexpr]-    (match mexpr math-expr-      {[<div <term $a $xs>-             <term $b $ys>>-        [(/ a b)-         (/ (foldl *' 1 (map 2#(**' %1 %2) xs))-            (foldl *' 1 (map 2#(**' %1 %2) ys)))]]})))+fromMonomial $mexpr :=+  match mexpr as mathExpr with+    | (term $a $xs) / (term $b $ys) ->+      (a / b, foldl (*') 1 (map (^') xs) / foldl (*') 1 (map (^') ys)) -;;-;; Map-;;-(define $map-polys-  (lambda [$fn $mexpr]-    (match mexpr math-expr-      {[<div $p1 $p2>-        (/' (fn p1) (fn p2))]})))+--+-- Map+--+mapPolys $fn $mexpr :=+  match mexpr as mathExpr with+    | $p1 / $p2 -> fn p1 /' fn p2 -(define $from-poly-  (lambda [$mexpr]-    (match mexpr math-expr-      {[<div <poly $ts1> $q>-        (map (lambda [$t1] (/' t1 q))-             ts1)]})))+fromPoly $mexpr :=+  match mexpr as mathExpr with+    | poly $ts1 / $q -> map (\t1 -> t1 /' q) ts1 -(define $map-poly-  (lambda [$fn $mexpr]-    (match mexpr math-expr-      {[<div <poly $ts1> $q>-        (foldl +' 0 (map (lambda [$t1] (fn (/' t1 q)))-                         ts1))]})))+mapPoly $fn $mexpr :=+  match mexpr as mathExpr with+    | poly $ts1 / $q -> foldl (+') 0 (map (\t1 -> fn (t1 /' q)) ts1) -(define $map-terms-  (lambda [$fn $mexpr]-    (match mexpr math-expr-      {[<div <poly $ts1> <poly $ts2>>-        (/' (foldl +' 0 (map fn ts1))-            (foldl +' 0 (map fn ts2)))]})))+mapTerms $fn $mexpr :=+  match mexpr as mathExpr with+    | poly $ts1 / poly $ts2 ->+      foldl (+') 0 (map fn ts1) /' foldl (+') 0 (map fn ts2) -(define $map-symbols-  (lambda [$fn $mexpr]-    (map-terms (lambda [$term]-                 (match term term-expr-                   {[<term $a $xs>-                     (*' a (foldl *' 1 (map 2#(match %1 symbol-expr-                                                {[<symbol _ _> (**' (fn %1) %2)]-                                                 [<apply $g $args>-                                                  (let {[$args'(map (map-symbols fn $) args)]}-                                                    (if (eq? args args')-                                                      (**' %1 %2)-                                                      (**' (fn (capply g args'))-                                                          %2)))-                                                  ]})-                                            xs)))]}))-               mexpr)))+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))+    mexpr -(define $contain-symbol?-  (lambda [$x $mexpr]-    (any id (match mexpr math-expr-              {[<div <poly $ts1> <poly $ts2>>-                (map (lambda [$term]-                       (match term term-expr-                         {[<term _ $xs>-                           (any id (map 2#(match %1 symbol-expr-                                            {[,x #t]-                                             [<apply _ $args> (any id (map (contain-symbol? x $) args))]-                                             [_ #f]})-                                        xs))]}))-                     {@ts1 @ts2})]}))))+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)) -(define $contain-function?-  (lambda [$f $mexpr]-    (any id (match mexpr math-expr-              {[<div <poly $ts1> <poly $ts2>>-                (map (lambda [$term]-                       (match term term-expr-                         {[<term _ $xs>-                           (any id (map 2#(match %1 symbol-expr-                                            {[<apply $g $args>-                                              (if (eq? f g)-                                                #t-                                                (any id (map (contain-function? f $) args)))]-                                             [_ #f]})-                                        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)) -(define $contain-function-with-order?-  (lambda [$f $n $mexpr]-    (any id (match mexpr math-expr-              {[<div <poly $ts1> <poly $ts2>>-                (map (lambda [$term]-                       (match term term-expr-                         {[<term _ $xs>-                           (any id (map 2#(match %1 symbol-expr-                                            {[<apply $g $args>-                                              (if (and (eq? f g) (gte? %2 n))-                                                #t-                                                (any id (map (contain-function-with-order? f n $) args)))]-                                             [_ #f]})-                                        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)) -(define $contain-function-with-index?-  (lambda [$mexpr]-    (any id (match mexpr math-expr-              {[<div <poly $ts1> <poly $ts2>>-                (map (lambda [$term]-                       (match term term-expr-                         {[<term _ $xs>-                           (any id (map 2#(match %1 symbol-expr-                                            {[<apply (& ?scalar? $f) $args>-                                              (match f math-expr-                                                {[<symbol _ !<nil>> #t]-                                                 [_ (any id (map (contain-function-with-index? $) args))]})]-                                             [<apply _ $args>-                                              (any id (map (contain-function-with-index? $) args))]-                                             [_ #f]})-                                        xs))]}))-                     {@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)) -(define $find-symbols-from-poly-  (lambda [$poly]-    (match-all poly math-expr-      [<poly <cons <term _ <cons (& <symbol _ _> $s) _>> _>> s])))+findSymbolsFromPoly $poly :=+  matchAll poly as mathExpr with+    | poly (term _ ((symbol _ _ & $s) :: _) :: _) -> s -;;;-;;; Substitute-;;;-(define $substitute-  (lambda [$ls $mexpr]-    (match ls (list [symbol-expr math-expr])-      {[<nil> mexpr]-       [<cons [$x $a] $rs>-        (substitute rs (substitute' x a mexpr))]})))+--+-- Substitute+--+substitute %ls $mexpr :=+  match ls as list (symbolExpr, mathExpr) with+    | [] -> mexpr+    | ($x, $a) :: $rs -> substitute rs (substitute' x a mexpr) -(define $substitute'-  (lambda [$x $a $mexpr]-    (map-symbols (rewrite-symbol x a $) mexpr)))+substitute' $x %a $mexpr := mapSymbols 1#(rewriteSymbol x a %1) mexpr -(define $rewrite-symbol-  (lambda [$x $a $sexpr]-    (match sexpr symbol-expr-      {[,x a]-       [_ sexpr]})))+rewriteSymbol $x $a $sexpr :=+  match sexpr as symbolExpr with+    | #x -> a+    | _ -> sexpr -(define $V.substitute-  (lambda [%xs %ys $mexpr]-    (substitute (zip (tensor-to-list xs) (tensor-to-list ys)) mexpr)))+V.substitute %xs %ys $mexpr :=+  substitute (zip (tensorToList xs) (tensorToList ys)) mexpr -(define $expand-all-  (lambda [$mexpr]-    (match mexpr math-expr-      {-       [?symbol? mexpr]-       ; function application-       [<apply $g $args>-        (capply g (map expand-all args))]-       ; quote-       [<quote $g> g]-       ; term (multiplication)-       [<term $a $ps>-        (* a (product (map 2#(** (expand-all %1) (expand-all %2)) ps)))]-       ; polynomial-       [<poly $ts> (sum (map (expand-all $) ts))]-       ; quotient-       [(/ $p1 $p2)-        (let {[$p1' (expand-all p1)]-              [$p2' (expand-all p2)]}-          (/ p1' p2'))]-       })))+expandAll $mexpr :=+  match mexpr as mathExpr with+    | ?isSymbol -> mexpr+    -- function application+    | apply $g $args -> capply g (map expandAll args)+    -- quote+    | quote $g -> g+    -- term (multiplication)+    | term $a $ps -> a * product (map 2#(expandAll %1 ^ expandAll %2) ps)+    -- polynomial+    | poly $ts -> sum (map expandAll ts)+    -- quotient+    | $p1 / $p2 ->+      let p1' := expandAll p1+          p2' := expandAll p2+       in p1' / p2' -(define $expand-all'-  (lambda [$mexpr]-    (match mexpr math-expr-      {-       [?symbol? mexpr]-       ; function application-       [<apply $g $args>-        (capply g (map expand-all' args))]-       ; quote-       [<quote $g> g]-       ; term (multiplication)-       [<term $a $ps>-        (*' a (product' (map 2#(**' (expand-all' %1) (expand-all' %2)) ps)))]-       ; polynomial-       [<poly $ts> (sum' (map (expand-all' $) ts))]-       ; quotient-       [(/ $p1 $p2)-        (let {[$p1' (expand-all' p1)]-              [$p2' (expand-all' p2)]}-          (/' p1' p2'))]-       })))+expandAll' $mexpr :=+  match mexpr as mathExpr with+    | ?isSymbol -> mexpr+    -- function application+    | apply $g $args -> capply g (map expandAll' args)+    -- quote+    | quote $g -> g+    -- term (multiplication)+    | term $a $ps -> a *' product' (map 2#(expandAll' %1 ^' expandAll' %2) ps)+    -- polynomial+    | poly $ts -> sum' (map expandAll' ts)+    -- quotient+    | $p1 / $p2 ->+      let p1' := expandAll' p1+          p2' := expandAll' p2+       in p1' /' p2' -;;;-;;; Coefficient-;;;-(define $coefficients-  (lambda [$f $x]-    (let {[$m (max {0 @(match-all f math-expr-                         [<div <poly <cons <term $a <ncons ,x $k $ts>> _>> _> k])})]}-      (map (coefficient f x $) (between 0 m)))))+--+-- Coefficient+--+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) -(define $coefficient-  (lambda [$f $x $m]-    (if (eq? m 0)-      (/ (sum (match-all f math-expr-                [<div <poly <cons <term $a (& !<cons ,x _> $ts)> _>> _>-                 (foldl *' a (map 2#(**' %1 %2) ts))]))-         (denominator f))-      (coefficient' f x m))))+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+    else coefficient' f x m -(define $coefficient'-  (lambda [$f $x $m]-    (/ (sum (match-all f math-expr-              [<div <poly <cons <term $a <ncons ,x $k $ts>> _>> _>-               (if (eq? m k)-                 (foldl *' a (map 2#(**' %1 %2) ts))-                 0)]))-       (denominator f))))+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 -(define $coefficient2-  (lambda [$f $x $y]-    (/ (sum (match-all f math-expr-              [<div <poly <cons <term $a <cons ,x <cons ,y $ts>>> _>> _>-               (foldl *' a (map 2#(**' %1 %2) ts))-               ]))-       (denominator f))))+coefficient2 $f $x $y :=+  sum+    (matchAll f as mathExpr with+      | poly (term $a (#x :: #y :: $ts) :: _) / _ ->+        foldl (*') a (map (^') ts)) / denominator f
lib/math/geometry/3d-euclidean-space.egi view
@@ -1,8 +1,8 @@-(define $coordinates {x y z})+coordinates := [x, y, z] -(define $metric-  (generate-tensor-    (match-lambda [integer integer]-      {[[$n ,n] 1]-       [[_ _] 0]})-    {3 3}))+metric :=+  generateTensor+    (\match as (integer, integer) with+      | ($n, #n) -> 1+      | (_, _) -> 0)+    [3, 3]
lib/math/geometry/4d-euclidean-space.egi view
@@ -1,8 +1,8 @@-(define $coordinates {x y z w})+coordinates := [x, y, z, w] -(define $metric-  (generate-tensor-    (match-lambda [integer integer]-      {[[$n ,n] 1]-       [[_ _] 0]})-    {4 4}))+metric :=+  generateTensor+    (\match as (integer, integer) with+      | ($n, #n) -> 1+      | (_, _) -> 0)+    [4, 4]
lib/math/geometry/differential-form.egi view
@@ -1,28 +1,21 @@-(define $df-normalize-  (lambda [%X]-    (let* {[$p (df-order X)]-           [[$es $os] (even-and-odd-permutations p)]}-      (with-symbols {i}-        (/ (- (sum (map (lambda [$σ] (subrefs X (map 1#i_(σ %1) (between 1 p)))) es))-              (sum (map (lambda [$σ] (subrefs X (map 1#i_(σ %1) (between 1 p)))) os)))-           (* (fact p)))))))+dfNormalize %X :=+  let p := dfOrder X+      (es, os) := evenAndOddPermutations p+   in withSymbols [i]+        (sum (map (\σ -> subrefs X (map 1#i_(σ %1) (between 1 p))) es)+       - sum (map (\σ -> subrefs X (map 1#i_(σ %1) (between 1 p))) os))+       / fact p -(define $wedge-  (lambda [%X %Y]-    !(. X Y)))+antisymmetrize := dfNormalize -(define $Lie.wedge-  (lambda [%X %Y]-    (- !(. X Y) !(. Y X))))+wedge %X %Y := X !. Y -(define $ι-  (lambda [%X %Y]-    (with-symbols {i}-      (* (df-order Y) (. X...~i (df-normalize Y..._i))))))+Lie.wedge %X %Y := X !. Y - Y !. X -(define $Lie-  (lambda [%X %Y]-    (match (df-order Y) integer-      {[,0 (ι X (d Y))]-       [,N (d (ι X Y))]-       [_ (+ (ι X (d Y)) (d (ι X Y)))]})))+ι %X %Y := withSymbols [i] dfOrder Y * (X...~i . dfNormalize Y..._i)++Lie %X %Y :=+  match dfOrder Y as integer with+    | #0 -> ι X (d Y)+    | #N -> d (ι X Y)+    | _ -> ι X (d Y) + d (ι X Y)
lib/math/geometry/minkowski-space.egi view
@@ -1,12 +1,9 @@-(define $coordinates {t x y z})--(define $metric-  (generate-tensor-    (match-lambda [integer integer]-      {[[,1 ,1] -1]-       [[$n ,n] 1]-       [[_ _] 0]})-    {4 4}))+coordinates := [t, x, y, z] -(define $.-  (lambda [$+metric :=+  generateTensor+    (\match as (integer, integer) with+      | (#1, #1) -> -1+      | ($n, #n) -> 1+      | (_, _) -> 0)+    [4, 4]
lib/math/normalize.egi view
@@ -1,268 +1,238 @@-;;;;;-;;;;;-;;;;; Term Rewriting-;;;;;-;;;;;--(define $math-normalize1-  (lambda [$x]-    (if (integer? x)-      x-      (let {[$ret ((capply compose (map 2#%1 (filter 2#(%2 x) rewrite-rules1))) x)]} ret))))-;      (let {[$ret ((capply compose (map 2#%1 (filter 2#(%2 fn x) rewrite-rules1))) (debug x))]} (debug ret)))))--(define $rewrite-rules1-  {-   [id 1##t]-   [rewrite-rule-for-i 1#(contain-symbol? i %1)]-   [rewrite-rule-for-w-term 1#(contain-symbol? w %1)]-   [rewrite-rule-for-rtu-term 1#(contain-function? `rtu %1)]-   [rewrite-rule-for-** 1#(contain-function? `** %1)]-   [rewrite-rule-for-exp 1#(contain-function? `exp %1)]-   [rewrite-rule-for-w-poly 1#(contain-symbol? w %1)]-   [rewrite-rule-for-rtu-poly 1#(contain-function? `rtu %1)]-   [rewrite-rule-for-sqrt 1#(contain-function? `sqrt %1)]-   [rewrite-rule-for-rt 1#(contain-function? `rt %1)]-;   [rewrite-rule-for-cos-and-sin 1#(or (contain-function-with-order? `cos 2 %1) (contain-function-with-order? `sin 2 %1))]-   [rewrite-rule-for-cos-to-sin 1#(contain-function-with-order? `cos 2 %1)]-   [rewrite-rule-for-d/d 1##t]-   })--;;-;; i-;;--(define $rewrite-rule-for-i rewrite-rule-for-i-term)--(define $rewrite-rule-for-i-term (map-terms rewrite-rule-for-i-term' $))+--+--+-- Term Rewriting+--+-- -(define $rewrite-rule-for-i-term'-  (lambda [$term]-    (match term math-expr-      {[(* $a ,i^(& ?even? $k) $r)-        (*' a (**' -1 (quotient k 2)) r)]-       [(* $a ,i^$k $r)-        (*' a (**' -1 (quotient k 2)) r i)]-       [_ term]})))+mathNormalize $x :=+  if isInteger x+    then x+    else (foldr compose id (map 2#%1 (filter 2#(%2 x) rewriteRules))) x -;;-;; w-;;+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) ] -(define $rewrite-rule-for-w-  (compose rewrite-rule-for-w-term-           rewrite-rule-for-w-poly $))+--+-- i+--+rewriteRuleForI := rewriteRuleForITerm -(define $rewrite-rule-for-w-term (map-terms rewrite-rule-for-w-term' $))-(define $rewrite-rule-for-w-poly (map-polys rewrite-rule-for-w-poly' $))+rewriteRuleForITerm := 1#(mapTerms rewriteRuleForITerm' %1) -(define $rewrite-rule-for-w-term'-  (lambda [$term]-    (match term math-expr-      {[(* $a ,w^(& ?(gte? $ 3) $k) $r)-        (*' a r (**' w (remainder k 3)))]-       [_ term]})))+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 -(define $rewrite-rule-for-w-poly'-  (lambda [$poly]-    (match poly math-expr-      {[(+ (* $a ,w^,2 $mr)-           (* $b ,w ,mr)-           $pr)-        (rewrite-rule-for-w-poly' (+' pr-                                     (*' -1 a mr)-                                     (*' (- b a) mr w)-                                     ))]-       [_ poly]})))+--+-- w+--+rewriteRuleForW := 1#(compose rewriteRuleForWTerm rewriteRuleForWPoly %1) -;;-;; rtu (include i and w)-;;+rewriteRuleForWTerm := 1#(mapTerms rewriteRuleForWTerm' %1) -(define $rewrite-rule-for-rtu-  (compose-           (map-terms rewrite-rule-for-rtu-term $)-           (map-polys rewrite-rule-for-rtu-poly $)-           ))+rewriteRuleForWPoly := 1#(mapPolys rewriteRuleForWPoly' %1) -(define $rewrite-rule-for-rtu-term (map-terms rewrite-rule-for-rtu-term' $))-(define $rewrite-rule-for-rtu-poly (map-polys rewrite-rule-for-rtu-poly' $))+rewriteRuleForWTerm' term :=+  match term as mathExpr with+    | $a * #w ^ (?(>= 3) & $k) * $r -> a *' r *' w ^' (k % 3)+    | _ -> term -(define $rewrite-rule-for-rtu-term'-  (lambda [$term]-    (match term math-expr-      {[(* $a (,`rtu $n)^(& ?(gte? $ n) $k) $r)-        (*' a (**' (rtu n) (remainder k n)) r)]-       [_ 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 -(define $rewrite-rule-for-rtu-poly'-  (lambda [$poly]-    (match poly math-expr-      {-       [(+ (* $a (,rtu $n)^,1 $mr)-           (loop $i [2 ,(- n 1)]-             (+ (* ,a ,(rtu n)^,i ,mr) ...)-             $pr))-        (rewrite-rule-for-rtu-poly' (+' pr (*' -1 a mr)))]-       [_ poly]})))+--+-- rtu (include i and w)+--+rewriteRuleForRtu :=+  compose+    1#(mapTerms rewriteRuleForRtuTerm %1)+    1#(mapPolys rewriteRuleForRtuPoly %1) -;;-;; sqrt-;;+rewriteRuleForRtuTerm := 1#(mapTerms rewriteRuleForRtuTerm' %1) -(define $rewrite-rule-for-sqrt (map-terms rewrite-rule-for-sqrt-term $))+rewriteRuleForRtuPoly := 1#(mapPolys rewriteRuleForRtuPoly' %1) -(define $rewrite-rule-for-sqrt-term-  (lambda [$term]-    (match term math-expr-      {[(* $a (,`sqrt $x) (,`sqrt ,x) $r)-        (rewrite-rule-for-sqrt (*' a x r))]-       [(* $a (,`sqrt (& ?term? $x)) (,`sqrt (& ?term? $y)) $r)-        (let* {[$d (gcd x y)]-               [[$a1 $x1] (from-monomial (/ x d))]-               [[$a2 $y1] (from-monomial (/ y d))]}-          (*' a d-             (sqrt (*' a1 a2)) (sqrt x1) (sqrt y1)-             r))]-       [_ term]})))+rewriteRuleForRtuTerm' term :=+  match term as mathExpr with+    | $a * #`rtu $n ^ (?(>= n) & $k) * $r -> a *' rtu n ^' (k % n) *' r+    | _ -> term -;;-;; rt (include sqrt)-;;+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 -(define $rewrite-rule-for-rt-  (map-terms rewrite-rule-for-rt-term $))+--+-- sqrt+--+rewriteRuleForSqrt := 1#(mapTerms rewriteRuleForSqrtTerm %1) -(define $rewrite-rule-for-rt-term-  (lambda [$term]-    (match term math-expr-      {[(* $a (,`rt $n $x)^(& ?(gte? $ n) $k) $r)-        (*' a (**' x (quotient k n)) (**' (rt n x) (remainder k n)) r)]-       [_ term]})))+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 -;;-;; exp-;;+--+-- rt (include sqrt)+--+rewriteRuleForRt := 1#(mapTerms rewriteRuleForRtTerm %1) -(define $rewrite-rule-for-exp (map-terms rewrite-rule-for-exp-term $))+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 -(define $rewrite-rule-for-exp-term-  (lambda [$term]-    (match term math-expr-      {[(* $a (,`exp $x)^(& ?(gte? $ 2) $n) $r)-        (rewrite-rule-for-exp (*' a (exp (* x n)) r))]-       [(* $a (,`exp $x) (,`exp $y) $r)-        (rewrite-rule-for-exp (*' a (exp (+ x y)) 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 * pi)) * $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 -(define $rewrite-rule-for-** (map-terms rewrite-rule-for-**-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 -(define $rewrite-rule-for-**-term-  (lambda [$term]-    (match term math-expr-      {[(* $a (,`** ,1 _)^_ $r)-        (rewrite-rule-for-** (*' a r))]-       [(* $a (,`** $x $y)^(& ?(gte? $ 2) $n) $r)-        (rewrite-rule-for-** (*' a (** x (* y n)) r))]-       [(* $a (,`** $x $y) (,`** ,x $z) $r)-        (rewrite-rule-for-** (*' a (** x (+ y z)) r))]-       [_ term]})))+--+-- power+--+rewriteRuleForPower := 1#(mapTerms rewriteRuleForPowerTerm %1) -;;-;; cos, sin-;;+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 -;(define $rewrite-rule-for-cos-and-sin 1#(rewrite-rule-for-cos-and-sin-expr (map-polys rewrite-rule-for-cos-and-sin-poly %1)))-(define $rewrite-rule-for-cos-and-sin 1#(map-polys rewrite-rule-for-cos-and-sin-poly %1))+--+-- cos, sin+--+rewriteRuleForCosAndSin := 1#(mapPolys rewriteRuleForCosAndSinPoly %1) -(define $rewrite-rule-for-cos-and-sin-expr-  (lambda [$expr]-    (match [expr expr] [math-expr math-expr]-      {[[<div (+ (* $a (,`cos $x) $mr)-                 $pr1)-              $pr2>-         (| <div (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _) _>-            <div _ (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _)>)]-        (rewrite-rule-for-cos-and-sin-expr (/' (+' (*' a (-' (cos (/ x 2))^2 (sin (/ x 2))^2) mr) pr1) pr2))]-       [[<div (+ (* $a (,`sin $x) $mr)-                 $pr1)-              $pr2>-         (| <div (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _) _>-            <div _ (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _)>)]-        (rewrite-rule-for-cos-and-sin-expr (/' (+' (*' (*' a 2) (*' (cos (/ x 2)) (sin (/ x 2))) mr) pr1) pr2))]-       [[<div $pr2-              (+ (* $a (,`cos $x) $mr)-                 $pr1)>-         (| <div (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _) _>-            <div _ (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _)>)]-        (rewrite-rule-for-cos-and-sin-expr (/' pr2 (+' (*' a (-' (cos (/ x 2))^2 (sin (/ x 2))^2) mr) pr1)))]-       [[<div $pr2-              (+ (* $a (,`sin $x) $mr)-                 $pr1)>-         (| <div (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _) _>-            <div _ (+ (* _ (| (,`cos ,(/ x 2)) (,`sin ,(/ x 2))) _) _)>)]-        (rewrite-rule-for-cos-and-sin-expr (/' pr2 (+' (*' (*' a 2) (*' (cos (/ x 2)) (sin (/ x 2))) mr) pr1)))]-       [_ expr]})))+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 -(define $rewrite-rule-for-cos-and-sin-poly-  (lambda [$poly]-    (match poly math-expr-      {[(+ (* $a (,`cos $x)^,2 $mr)-           (* ,a (,`sin ,x)^,2 ,mr)-           $pr)-        (rewrite-rule-for-cos-and-sin-poly (+' pr (*' a mr)))]-       [(+ (* $a $mr)-           (* ,(* -1 a) (,`sin $x)^,2 ,mr)-           $pr)-        (rewrite-rule-for-cos-and-sin-poly (+' pr (*' a (cos x)^2 mr)))]-       [(+ (* $a $mr)-           (* ,(* -1 a) (,`cos $x)^,2 ,mr)-           $pr)-        (rewrite-rule-for-cos-and-sin-poly (+' pr (*' a (sin x)^2 mr)))]-       [_ poly]})))+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 -(define $rewrite-rule-for-cos-to-sin 1#(map-terms rewrite-rule-for-cos-to-sin-term' %1))+rewriteRuleForCosToSin := 1#(mapTerms rewriteRuleForCosToSinTerm' %1) -(define $rewrite-rule-for-cos-to-sin-term'-  (lambda [$term]-    (match term math-expr-      {[(* $a (,`cos $x)^,2 $mr)-        (*' a (-' 1 (sin x)^2) (rewrite-rule-for-cos-to-sin-term' mr))]-       [_ term]})))+rewriteRuleForCosToSinTerm' term :=+  match term as mathExpr with+    | $a * #`cos $x ^ #2 * $mr ->+      a *' (1 -' sin x ^ 2) *' rewriteRuleForCosToSinTerm' mr+    | _ -> term -;;-;; d-;;+rewriteRuleForSin mExpr := mapTerms f mExpr+  where+    f term :=+      match term as mathExpr with+        | _ * #`sin #0 * _ -> 0+        | _ * #`sin (mult _ #pi) * _ -> 0+        | $a * #`sin (mult $n #pi / #2) * $mr ->+          a *' (-1) ^ ((abs n - 1) / 2) *' mr+        | _ -> term -(define $rewrite-rule-for-d (map-terms rewrite-rule-for-d-term $))+rewriteRuleForCos mExpr := mapTerms f mExpr+  where+    f term :=+      match term as mathExpr with+        | $a * #`cos #0 * $mr -> a *' mr+        | $a * #`cos (term $n [#pi]) * $mr -> a *' (-1) ^ abs n *' mr+        | _ * #`cos (mult _ #pi / #2) * _ -> 0+        | _ -> term -(define $rewrite-rule-for-d-term-  (lambda [$term]-    (match term math-expr-      {[(* _ (,d _) (,d _) _)-        0]-       [_ term]})))+--+-- d+--+rewriteRuleForD := 1#(mapTerms rewriteRuleForDTerm %1) -;;-;; d/d-;;+rewriteRuleForDTerm term :=+  match term as mathExpr with+    | _ * #d _ * #d _ * _ -> 0+    | _ -> term -(define $rewrite-rule-for-d/d (map-polys rewrite-rule-for-d/d-poly $))+--+-- d/d+--+rewriteRuleForD/d := 1#(mapPolys rewriteRuleForD/dPoly %1) -(define $rewrite-rule-for-d/d-poly-  (lambda [$poly]-    (match poly math-expr-      {-       [(+ (* $a (& $f <func $g _ $arg $js>)^$n $mr)-           (* $b <func ,g _ ,arg ?1#(eq?/m (multiset something) js %1)>^,n ,mr)-           $pr)-       (rewrite-rule-for-d/d-poly (+' (*' (+ a b) f^n mr) pr))]-;       [(+ (* $a <apply (& ?scalar? $g <symbol $f $subs>) $args>^$n $mr)-;           (* $b <apply (& ?scalar? <symbol ,f ?1#(eq?/m (multiset something) subs %1)>) ,args>^,n ,mr)-;           $pr)-;       (+ (*' (+ a b) (`g args)^n mr) pr)]-       [_ poly]})))+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
− nons-sample/math/geometry/curvature-form.egi 
@@ -1,32 +0,0 @@-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--Γ_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--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, (sin θ)^2 |], [| -1, 0 |] |]~#_#-assertEqual "Riemann curvature" R~#_#_2_1 [| [| 0, -1 * (sin θ)^2 |], [| 1, 0 |] |]~#_#-assertEqual "Riemann curvature" R~#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]~#_#--ω := Γ~#_#_#--d %t := !(flip ∂/∂) x t--infixl expression 7 ∧--(∧) %x %y := x !. y--Ω := withSymbols [i, j]-       antisymmetrize (d ω~i_j + ω~i_k ∧ ω~k_j)--assertEqual "Curvature form" Ω~#_#_1_1 [| [| 0, 0 |], [| 0, 0 |] |]~#_#-assertEqual "Curvature form" Ω~#_#_1_2 [| [| 0, (sin θ)^2  / 2|], [| -1 / 2, 0 |] |]~#_#-assertEqual "Curvature form" Ω~#_#_2_1 [| [| 0, -1 * (sin θ)^2 / 2 |], [| 1 / 2, 0 |] |]~#_#-assertEqual "Curvature form" Ω~#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]~#_#
− nons-sample/math/geometry/hodge-laplacian-polar.egi 
@@ -1,37 +0,0 @@--- Parameters and metrics--N := 2--x := [|r, θ|]--g_i_j := [| [| 1, 0 |], [| 0, r^2 |] |]_i_j-g~i~j := [| [| 1, 0 |], [| 0, 1 / r^2 |] |]~i~j---- Hodge Laplacian--d %A := !(flip ∂/∂) x A--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 :=-  let k := dfOrder A in-    -1^(N * (k + 1) + 1) * (hodge (d (hodge A)))--Δ %A :=-  match (dfOrder A) as integer with-  | #0 -> δ (d A)-  | #N -> d (δ A)-  | _  -> d (δ A) + δ (d A)--f := function (r, θ)--assertEqual "exterior derivative" (d f) [| ∂/∂ f r, ∂/∂ f θ |]--assertEqual "hodge operator" (hodge (d f)) [| (-1 * ∂/∂ f θ) / r, r * (∂/∂ f r) |]--assertEqual "Laplacian" (Δ f) ((-1 / r^2) * ((∂/∂ (∂/∂ f θ) θ) + r * (∂/∂ f r) + (r^2 * (∂/∂ (∂/∂ f r) r))))
− nons-test/test/dp.egi 
@@ -1,47 +0,0 @@-literal := integer--deleteLiteral l cnf :=-  map (\matchAll as multiset integer with-       | (!#l & $x) :: _ -> x)-      cnf--deleteClausesWith l cnf :=-  matchAll cnf as multiset (multiset integer) with-  | (!(#l :: _) & $c) :: _ -> c--assignTrue l cnf :=-  deleteLiteral (neg l) (deleteClausesWith l cnf)--resolveOn v cnf :=-  matchAll cnf as multiset (multiset integer) with-  | {(#v :: (@ & $xs)) :: (#(neg v) :: (@ & $ys)) :: _,-     !($l :: _, #(neg l) :: _)}-    -> unique (xs ++ ys)--dp vars cnf :=-  match (vars, cnf) as (multiset literal, multiset (multiset literal)) with-  -- satisfiable-  | (_, []) -> True-  -- unsatisfiable-  | (_, [] :: _) -> False-  -- 1-literal rule-  | (_, (($l :: []) :: _))-  -> dp (delete (abs l) vars) (assignTrue l cnf)-  -- pure literal rule (positive)-  | ($v :: $vs, !((#(neg v) :: _) :: _))-  -> dp vs (assignTrue v cnf)-  -- pure literal rule (negative)-  | ($v :: $vs, !((#v :: _) :: _))-  -> dp vs (assignTrue (neg v) cnf)-  -- otherwise-  | ($v :: $vs, _)-  -> dp vs (resolveOn v cnf ++-            deleteClausesWith v (deleteClausesWith (neg v) cnf))--assertEqual "dp" (dp [1] [[1]]) True-assertEqual "dp" (dp [1] [[1],[-1]]) False-assertEqual "dp" (dp [1,2,3] [[1,2],[-1,3],[1,-3]]) True-assertEqual "dp" (dp [1,2] [[1,2],[-1,-2],[1,-2]]) True-assertEqual "dp" (dp [1,2] [[1,2],[-1,-2],[1,-2],[-1,2]]) False-assertEqual "dp" (dp [1,2,3,4,5] [[-1,-2,3],[-1,-2,-3],[1,2,3,4],[-4,-2,3],[5,1,2,-3],[-3,1,-5],[1,-2,3,4],[1,-2,-3,5]]) True-assertEqual "dp" (dp [1,2] [[-1,-2],[1]]) True
− nons-test/test/lib/core/base.egi 
@@ -1,62 +0,0 @@------ Matchers-----assert "bool's value pattern"-  (match (True, False) as (bool, bool) with-   | #(True, False) -> True-   | _ -> False)--assert "char's value pattern"-  (match 'a' as char with-   | #'a' -> True-   | _ -> False)--assert "integer's value pattern"-  (match 10 as integer with-   | #10 -> True-   | _ -> False)--assert "float's value pattern"-  (match 0.1 as float with-   | #0.1 -> True-   | _ -> False)------- Utility----assertEqual "id" (id 1) 1--assertEqual "fst" (fst (1, 2)) 1--assertEqual "snd" (snd (1, 2)) 2--assertEqual "compose - case 1" ((compose (fst, snd)) ((1, 2), 3)) 2--assertEqual "compose - case 2" ((compose (fst, snd, fst)) ((1, (2, 3)), 4)) 2--assertEqual "eq?/m" (eq?/m integer 1 1) True------- Booleans----assertEqual "and"-  [True && True, True && False, False && True, False && False]-  [True, False, False, False]--assertEqual "or"-  [True || True, True || False, False || True, False || False]-  [True, True, True, False]--assertEqual "not"-  [not True, not False]-  [False, True]------- Unordered-Pair-----assertEqual "unorderedPair matcher"-  (match (1, 2) as unorderedPair integer with-   | (#2, $x) -> x)-  1
− nons-test/test/lib/core/collection.egi 
@@ -1,331 +0,0 @@------ This file has been auto-generated by egison-translator.-----assert-  "list's value pattern"-  (match [1, 2, 3] as list integer with-    | #([1] ++ 2 :: [3]) -> True-    | _ -> False)--assert-  "list's nil - case 1"-  (match [] as list integer with-    | [] -> True-    | _ -> False)--assert-  "list's nil - case 2"-  (match [1] as list integer with-    | [] -> False-    | _ -> True)--assertEqual-  "list's cons"-  (match [1, 2, 3] as list integer with-    | $n :: $ns -> (n, ns))-  (1, [2, 3])--assertEqual-  "list's cons with value pattern"-  (match [1, 2, 3] as list integer with-    | #1 :: $ns -> ns)-  [2, 3]--assertEqual-  "list's snoc"-  (match [1, 2, 3] as list integer with-    | snoc $n $ns -> (n, ns))-  (3, [1, 2])--assertEqual-  "list's snoc with value pattern"-  (match [1, 2, 3] as list integer with-    | snoc #3 $ns -> ns)-  [1, 2]--assertEqual-  "list's join"-  (matchAll [1, 2, 3] as list integer with-    | $xs ++ $ys -> (xs, ys))-  [([], [1, 2, 3]), ([1], [2, 3]), ([1, 2], [3]), ([1, 2, 3], [])]--assertEqual-  "list's join with value pattern"-  (match [1, 2, 3] as list integer with-    | #[1] ++ $ns -> ns)-  [2, 3]--assertEqual-  "list's nioj"-  (matchAll [1, 2, 3] as list integer with-    | nioj $xs $ys -> (xs, ys))-  [([], [1, 2, 3]), ([3], [1, 2]), ([2, 3], [1]), ([1, 2, 3], [])]--assertEqual-  "list's nioj with value pattern"-  (match [1, 2, 3] as list integer with-    | nioj #[3] $ns -> ns)-  [1, 2]--assertEqual-  "sorted-list - join-cons 1"-  (matchAll [3, 1, 2, 4] as sortedList integer with-    | _ ++ #3 :: $xs -> xs)-  [[1, 2, 4]]--assertEqual-  "sorted-list - join-cons 2"-  (matchAll [3, 1, 2, 4] as sortedList integer with-    | _ ++ #2 :: $xs -> xs)-  []--assert-  "multiset's nil - case 1"-  (match [] as multiset integer with-    | [] -> True-    | _ -> False)--assert-  "multiset's nil - case 2"-  (match [1] as multiset integer with-    | [] -> False-    | _ -> True)--assert-  "multiset's value pattern"-  (match [1, 1, 1, 2, 3] as multiset integer with-    | #([1] ++ (2 :: [1, 3]) ++ [1]) -> True-    | _ -> False)--assertEqual-  "multiset's cons"-  (matchAll [1, 2, 3] as multiset integer with-    | $n :: $ns -> (n, ns))-  [(1, [2, 3]), (2, [1, 3]), (3, [1, 2])]--assertEqual-  "multiset's cons with value pattern"-  (match [1, 2, 3] as multiset integer with-    | #2 :: $ns -> ns)-  [1, 3]--assertEqual-  "multiset's join"-  (matchAll [1, 2, 3] as multiset integer with-    | $xs ++ $ys -> (xs, ys))-  [ ([], [1, 2, 3])-  , ([1], [2, 3])-  , ([2], [1, 3])-  , ([3], [1, 2])-  , ([1, 2], [3])-  , ([1, 3], [2])-  , ([2, 3], [1])-  , ([1, 2, 3], []) ]--assertEqual-  "multiset's join with value pattern - case 1"-  (match [1, 2, 3] as multiset integer with-    | #[1] ++ $ns -> ns)-  [2, 3]--assertEqual-  "multiset's join with value pattern - case 2"-  (matchAll [1, 2, 3] as multiset integer with-    | #[1, 3] ++ $ys -> ys)-  [[2]]--assertEqual-  "multiset's join with value pattern - case 3"-  (matchAll [1, 2, 3] as multiset integer with-    | #[1, 5, 3] ++ $ys -> ys)-  []--assert-  "set's nil - case 1"-  (match [] as set integer with-    | [] -> True-    | _ -> False)--assert-  "set's nil - case 2"-  (match [1] as set integer with-    | [] -> False-    | _ -> True)--assertEqual-  "set's cons"-  (matchAll [1, 2, 3] as set integer with-    | $n :: $ns -> (n, ns))-  [(1, [1, 2, 3]), (2, [1, 2, 3]), (3, [1, 2, 3])]--assertEqual-  "set's cons with value pattern"-  (match [1, 2, 3] as set integer with-    | #2 :: $ns -> ns)-  [1, 2, 3]--assertEqual-  "set's join"-  (matchAll [1, 2, 3] as set integer with-    | $xs ++ $ys -> (xs, ys))-  [ ([], [1, 2, 3])-  , ([1], [1, 2, 3])-  , ([2], [1, 2, 3])-  , ([3], [1, 2, 3])-  , ([1, 2], [1, 2, 3])-  , ([1, 3], [1, 2, 3])-  , ([2, 3], [1, 2, 3])-  , ([1, 2, 3], [1, 2, 3]) ]--assertEqual-  "set's join with value pattern 1"-  (matchAll [1, 2, 3] as set integer with-    | #[1, 3] ++ $ys -> ys)-  [[1, 2, 3]]--assertEqual-  "set's join with value pattern 2"-  (matchAll [1, 2, 3] as set integer with-    | #[1, 5, 3] ++ $ys -> ys)-  []--assertEqual "nth" (nth 1 [1, 2, 3]) 1--assertEqual "take" (take 2 [1, 2, 3]) [1, 2]--assertEqual "drop" (drop 2 [1, 2, 3]) [3]--assertEqual "take-and-drop" (takeAndDrop 2 [1, 2, 3]) ([1, 2], [3])--assertEqual "take-while" (takeWhile 1#(%1 < 10) primes) [2, 3, 5, 7]--assertEqual "cons" (1 :: [2, 3]) [1, 2, 3]--assertEqual "car" (car [1, 2, 3]) 1--assertEqual "cdr" (cdr [1, 2, 3]) [2, 3]--assertEqual "rac" (rac [1, 2, 3]) 3--assertEqual "rdc" (rdc [1, 2, 3]) [1, 2]--assertEqual "length" (length [1, 2, 3]) 3--assertEqual "map" (map 1#(%1 * 2) [1, 2, 3]) [2, 4, 6]--assertEqual "map2" (map2 (*) [1, 2, 3] [10, 20, 30]) [10, 40, 90]--assertEqual-  "filter"-  (let odd? n := modulo n 2 = 1-    in filter odd? [1, 2, 3])-  [1, 3]--assertEqual "zip" (zip [1, 2, 3] [10, 20, 30]) [(1, 10), (2, 20), (3, 30)]--assertEqual "lookup" (lookup 2 [(1, 10), (2, 20), (3, 30)]) 20--assertEqual "foldr" (foldr (\n ns -> n :: ns) [] [1, 2, 3]) [1, 2, 3]--assertEqual "foldl" (foldl (\ns n -> n :: ns) [] [1, 2, 3]) [3, 2, 1]--assertEqual "scanl" (scanl (\r n -> r * n) 2 [2, 2, 2]) [2, 4, 8, 16]--assertEqual "append" ([1, 2] ++ [3, 4, 5]) [1, 2, 3, 4, 5]--assertEqual "concat" (concat [[1, 2], [3, 4, 5]]) [1, 2, 3, 4, 5]--assertEqual "reverse" (reverse [1, 2, 3]) [3, 2, 1]--assertEqual-  "intersperse"-  (intersperse [0] [[1, 2], [3, 3], [4], []])-  [[1, 2], [0], [3, 3], [0], [4], [0], []]--assertEqual-  "intercalate"-  (intercalate [0] [[1, 2], [3, 3], [4], []])-  [1, 2, 0, 3, 3, 0, 4, 0]--assertEqual-  "split"-  (split [0] [1, 2, 0, 3, 3, 0, 4, 0])-  [[1, 2], [3, 3], [4], []]--assertEqual-  "split/m"-  (split/m integer [0] [1, 2, 0, 3, 3, 0, 4, 0])-  [[1, 2], [3, 3], [4], []]--assertEqual-  "find-cycle"-  (findCycle [1, 3, 4, 5, 2, 7, 5, 2, 7, 5, 2, 7])-  ([1, 3, 4], [5, 2, 7])--assertEqual "repeat" (take 5 (repeat [1, 2, 3])) [1, 2, 3, 1, 2]--assertEqual "repeat1" (take 5 (repeat1 2)) [2, 2, 2, 2, 2]--assertEqual "all - case 1" (all 1#(%1 = 1) [1, 1, 1]) True--assertEqual "all - case 2" (all 1#(%1 = 1) [1, 1, 2]) False--assertEqual "any - case 1" (any 1#(%1 = 1) [0, 1, 0]) True--assertEqual "any - case 2" (any 1#(%1 = 1) [0, 0, 0]) False--assertEqual "from" (take 3 (from 2)) [2, 3, 4]--assertEqual "between" (between 2 5) [2, 3, 4, 5]--assertEqual "add - case 1" (add 1 [2, 3]) [2, 3, 1]--assertEqual "add - case 2" (add 1 [1, 2, 3]) [1, 2, 3]--assertEqual "add/m - case 1" (add/m integer 1 [2, 3]) [2, 3, 1]--assertEqual "add/m - case 2" (add/m integer 1 [1, 2, 3]) [1, 2, 3]--assertEqual "delete-first" (deleteFirst 2 [1, 2, 3, 2]) [1, 3, 2]--assertEqual "delete-first/m" (deleteFirst/m integer 2 [1, 2, 3, 2]) [1, 3, 2]--assertEqual "delete" (delete 2 [1, 2, 3, 1, 2, 3]) [1, 3, 1, 3]--assertEqual "delete/m" (delete/m integer 2 [1, 2, 3, 1, 2, 3]) [1, 3, 1, 3]--assertEqual "difference" (difference [1, 2, 3] [1, 3]) [2]--assertEqual "difference/m" (difference/m integer [1, 2, 3] [1, 3]) [2]--assertEqual "union" (union [1, 2, 3] [1, 3, 4]) [1, 2, 3, 4]--assertEqual "union/m" (union/m integer [1, 2, 3] [1, 3, 4]) [1, 2, 3, 4]--assertEqual "intersect" (intersect [1, 2, 3] [1, 3, 4]) [1, 3]--assertEqual "intersect/m" (intersect/m integer [1, 2, 3] [1, 3, 4]) [1, 3]--assertEqual "member? - case 1" (member? 1 [1, 3, 1, 4]) True--assertEqual "member? - case 2" (member? 2 [1, 3, 1, 4]) False--assertEqual "member?/m - case 1" (member?/m integer 1 [1, 3, 1, 4]) True--assertEqual "member?/m - case 2" (member?/m integer 2 [1, 3, 1, 4]) False--assertEqual "count" (count 1 [1, 3, 1, 4]) 2--assertEqual "count/m" (count/m integer 1 [1, 3, 1, 4]) 2--assertEqual "frequency" (frequency [1, 3, 1, 4]) [(1, 2), (3, 1), (4, 1)]--assertEqual-  "frequency/m"-  (frequency/m integer [1, 3, 1, 4])-  [(1, 2), (3, 1), (4, 1)]--assertEqual "unique" (unique [1, 2, 3, 2, 1, 4]) [1, 2, 3, 4]--assertEqual "unique/m" (unique/m integer [1, 2, 3, 2, 1, 4]) [1, 2, 3, 4]
− nons-test/test/lib/core/number.egi 
@@ -1,118 +0,0 @@------ Matcher-----assertEqual "nat's o - case 1"-  (match 0 as nat with-    | o -> True-    | _ -> False)-  True--assertEqual "nat's o - case 2"-  (match 1 as nat with-    | o -> True-    | _ -> False)-  False--assertEqual "nat's s - case 1"-  (match 10 as nat with-    | s $n -> n)-  9--assertEqual "nat's s - case 2"-  (match 0 as nat with-    | s o -> True-    | _ -> False)-  False------- Sequences-----assertEqual "nats" (take 10 nats) [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]--assertEqual "nats0" (take 10 nats0) [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]--assertEqual "odds" (take 10 odds) [1, 3, 5, 7, 9, 11, 13, 15, 17, 19]--assertEqual "evens" (take 10 evens) [2, 4, 6, 8, 10, 12, 14, 16, 18, 20]--assertEqual "primes" (take 10 primes) [2, 3, 5, 7, 11, 13, 17, 19, 23, 29]------- Natural numbers-----assertEqual "divisor?" (divisor? 10 5) True--assertEqual "find-factor" (findFactor 100) 2--assertEqual "p-f" (pF 100) [2, 2, 5, 5]--assertEqual "odd? - case 1" (odd? 3) True--assertEqual "odd? - case 2" (odd? 4) False--assertEqual "even? - case 1" (even? 4) True--assertEqual "even? - case 2" (even? 5) False--assertEqual "prime? - case 1" (prime? 17) True--assertEqual "prime? - case 2" (prime? 18) False--assertEqual "perm" (perm 5 2) 20--assertEqual "comb" (comb 5 2) 10--assertEqual "n-adic - case 1" (nAdic 10 123) [1, 2, 3]--assertEqual "n-adic - case 2" (nAdic 2 10) [1, 0, 1, 0]--assertEqual "rtod"-  (2#(%1, take 10 %2) (rtod (6 / 35)))-  (0, [1, 7, 1, 4, 2, 8, 5, 7, 1, 4])--assertEqual "rtod'" (rtod' (6 / 35)) (0, [1], [7, 1, 4, 2, 8, 5])--assertEqual "show-decimal" (showDecimal 10 (6 / 35)) "0.1714285714"--assertEqual "show-decimal'" (showDecimal' (6 / 35)) "0.1 714285 ..."--assertEqual-  "regular-continued-fraction sqrt of 2"-  (rtof-     (regularContinuedFraction-        1-        [2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2]))-  1.4142135623730951--assertEqual "regular-continued-fraction pi"-  (rtof-     (regularContinuedFraction-        3-        [7, 15, 1, 292, 1, 1, 1, 2, 1, 3, 1, 14, 2, 1, 1, 2, 2, 2, 2, 1, 84, 2,-         1, 1, 15, 3, 13]))-  3.141592653589793--assertEqual "continued-fraction pi"-  (rtof-     (continuedFraction-        3-        [7, 15, 1, 292, 1, 1, 1, 2, 1, 3, 1, 14, 2, 1, 1, 2, 2, 2, 2, 1, 84, 2,-         1, 1, 15, 3, 13]-        [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,-         1, 1, 1]))-  3.141592653589793--assertEqual-  "regular-continued-fraction-of-sqrt case 1"-  (2#(%1, take 10 %2) (regularContinuedFractionOfSqrt 2))-  (1, [2, 2, 2, 2, 2, 2, 2, 2, 2, 2])--assertEqual-  "regular-continued-fraction-of-sqrt case 2"-  (rtof-     (regularContinuedFraction-        (2#(%1, take 100 %2) (regularContinuedFractionOfSqrt 2))))-  1.4142135623730951
− nons-test/test/lib/core/order.egi 
@@ -1,35 +0,0 @@-assertEqual "compare - case 1"-  (compare 10 10)-  Equal--assertEqual "compare - case 2"-  (compare 11 10)-  Greater--assertEqual "compare - case 3"-  (compare 10 11)-  Less--assertEqual "min"-  (min [20, 5])-  5--assertEqual "min/fn"-  (min/fn compare [10, 20, 5, 20, 30])-  5--assertEqual "max"-  (max [5, 30])-  30--assertEqual "max/fn"-  (max/fn compare [10, 20, 5, 20, 30])-  30--assertEqual "sort"-  (sort [10, 20, 5, 20, 30])-  [5, 10, 20, 20, 30]--assertEqual "sort/fn"-  (sort/fn compare [10, 20, 5, 20, 30])-  [5, 10, 20, 20, 30]
− nons-test/test/lib/core/string.egi 
@@ -1,69 +0,0 @@-assert "string's value pattern"-  (match "abc" as string with-    | #"abc" -> True-    | _ -> False)--assert "string's nil - case 1"-  (match "" as string with-    | [] -> True-    | _ -> False)--assert "string's nil - case 2"-  (match "abc" as string with-    | [] -> False-    | _ -> True)--assertEqual "string's cons"-  (matchAll "abc" as string with-    | $x :: $xs -> (x, xs))-  [('a', "bc")]--assertEqual "string's join"-  (matchAll "abc" as string with-    | $xs ++ $ys -> (xs, ys))-  [("", "abc"), ("a", "bc"), ("ab", "c"), ("abc", "")]------- String as collection----assertEqual "S.empty? - case 1" (S.empty? "") True--assertEqual "S.empty? - case 2" (S.empty? "Egison") False--assertEqual "S.car" (S.car "Egison") 'E'--assertEqual "S.cdr" (S.cdr "Egison") "gison"--assertEqual "S.rac" (S.rac "Egison") 'n'--assertEqual "S.map" (S.map id "Egison") "Egison"--assertEqual "S.length" (S.length "Egison") 6--assertEqual "S.split"-  (S.split "," "Lisp,Haskell,Egison")-  ["Lisp", "Haskell", "Egison"]--assertEqual "S.append" (S.append "Egi" "son") "Egison"--assertEqual "S.concat" (S.concat ["Egi", "son"]) "Egison"--assertEqual "S.intercalate"-  (S.intercalate "," ["Lisp", "Haskell", "Egison"])-  "Lisp,Haskell,Egison"------- Characters-----assertEqual "C.between" (C.between 'a' 'c') ['a', 'b', 'c']--assertEqual "C.between?" (C.between? 'a' 'c' 'b') True--assertEqual "alphabet?" (alphabet? 'a') True--assertEqual "alphabets?" (alphabets? "Egison") True--assertEqual "upper-case" (upperCase 'e') 'E'--assertEqual "lower-case" (lowerCase 'E') 'e'
− nons-test/test/lib/math/algebra.egi 
@@ -1,21 +0,0 @@------ This file has been auto-generated by egison-translator.-----assertEqual "q-f' - case 1" (qF' 1 2 1) (-1, -1)--assertEqual-  "q-f' - case 2"-  (qF' 1 1 (-1))-  (((-1) + sqrt 5) / 2, ((-1) + (- sqrt 5)) / 2)--assertEqual-  "q-f' - case 3"-  (qF' 1 (- (((-1) + sqrt 5) / 2)) 1)-  ( ((-1) + sqrt 5 + sqrt ((-10) + (-2) * sqrt 5)) / 4-  , ((-1) + sqrt 5 + (- sqrt ((-10) + (-2) * sqrt 5))) / 4 )--assertEqual-  "fifth root of unity"-  ((((-1) + sqrt 5 + sqrt ((-10) + (-2) * sqrt 5)) / 4) ^ 5)-  1
− nons-test/test/lib/math/analysis.egi 
@@ -1,37 +0,0 @@------ This file has been auto-generated by egison-translator.-----assertEqual "d/d - case 1" (d/d (x ^ 2) x) (2 * x)--assertEqual "d/d - case 2" (d/d (a ^ (x ^ 2)) x) (2 * a ^ (x ^ 2) * log a * x)--assertEqual "d/d - case 3" (d/d (cos x * sin x) x) ((- (sin x ^ 2)) + cos x ^ 2)--assertEqual-  "d/d - case 4"-  (d/d (sigmoid z) z)-  (exp (- z) / (1 + 2 * exp (- z) + exp (- z) ^ 2))--assertEqual "d/d - case 5" (d/d (d/d (log x) x) x) ((-1) / x ^ 2)--assertEqual-  "tailor-expansion - case 1"-  (take 4 (taylorExpansion (e ^ (i * x)) x 0))-  [`exp 0, `exp 0 * i * x, (- `exp 0) * x ^ 2 / 2, (- `exp 0) * i * x ^ 3 / 6]--assertEqual-  "multivariate-tailor-expansion - case 1"-  (take 3 (multivariateTaylorExpansion (f x y) [|x, y|] [|0, 0|]))-  [ f 0 0-  , x * f|1 0 0 + y * f|2 0 0-  , (x ^ 2 * f|1|1 0 0 + x * y * f|1|2 0 0 + x * y * f|2|1 0 0 + y ^ 2 * f|2|2-                                                                           0-                                                                           0) / 2 ]--assertEqual-  "function expr"-  (let f := function (x, y)-    in d/d f y)-  (let f := function (x, y)-    in userRefs f [y])
− nons-test/test/lib/math/arithmetic.egi 
@@ -1,22 +0,0 @@------ This file has been auto-generated by egison-translator.-----assertEqual "sum" (sum (take 5 nats)) 15--assertEqual "product" (product (take 5 nats)) 120--assertEqual "power" (power 2 5) 32--assertEqual "** - case 1" (power x 3) (x ^ 3)--assertEqual "** - case 2" (power (sqrt 2) 4) 4--assertEqual "gcd" (gcd 15 40) 5--assertEqual "sqrt - case 1" (sqrt (50 * x ^ 2 / y)) (5 * x * sqrt (2 * y) / y)--assertEqual-  "sqrt - case 2"-  (sqrt (3 * x) * sqrt (2 * y))-  (sqrt 6 * sqrt x * sqrt y)
− nons-test/test/lib/math/tensor.egi 
@@ -1,73 +0,0 @@------ This file has been auto-generated by egison-translator.-----assertEqual-  "Tensor product - case 1"-  ([|[|1, 1|], [|0, 1|]|]~i~j . [|[|1, 1|], [|0, 1|]|]_j_k)-  [|[|1, 2|], [|0, 1|]|]--assertEqual-  "Tensor product - case 2"-  ([|[|1, 1|], [|0, 1|]|]~i~j . [|[|1, 1|], [|0, 1|]|]_j~k . [|[|1, 1|]-  , [|0, 1|]|]_k_l)-  [|[|1, 3|], [|0, 1|]|]~i_l--assertEqual "Vector *" (V.* [|1, 1, 0|] [|10, 5, 10|]) 15--assertEqual-  "Matrix * - case 1"-  (M.* [|[|1, 1|], [|0, 1|]|] [|[|1, 1|], [|0, 1|]|])-  [|[|1, 2|], [|0, 1|]|]--assertEqual-  "Matrix * - case 2"-  (M.* [|[|1, 1|], [|0, 1|]|] [|[|1, 1|], [|0, 1|]|] [|[|1, 1|], [|0, 1|]|])-  [|[|1, 3|], [|0, 1|]|]--assertEqual "Tensor '+' - case 1" (1 + [|1, 2, 3|]) [|2, 3, 4|]--assertEqual "Tensor '+' - case 2" ([|1, 2, 3|] + 1) [|2, 3, 4|]--assertEqual-  "Tensor '+' - case 3"-  ([|[|11, 12|], [|21, 22|], [|31, 32|]|]_i_j + [|100, 200, 300|]_i)-  [|[|111, 112|], [|221, 222|], [|331, 332|]|]_i_j--assertEqual-  "Tensor '+' - case 4"-  ([|100, 200, 300|]_i + [|[|11, 12|], [|21, 22|], [|31, 32|]|]_i_j)-  [|[|111, 112|], [|221, 222|], [|331, 332|]|]_i_j--assertEqual-  "Tensor '+' - case 5"-  ([|[|1, 2, 3|], [|10, 20, 30|]|]_i_j + [|100, 200, 300|]_j)-  [|[|101, 202, 303|], [|110, 220, 330|]|]_i_j--assertEqual-  "Tensor '+' - case 6"-  ([|100, 200, 300|]_j + [|[|1, 2, 3|], [|10, 20, 30|]|]_i_j)-  [|[|101, 110|], [|202, 220|], [|303, 330|]|]_j_i--assertEqual-  "append indices with ..."-  (let A := generateTensor 2#1 [2, 2]-       f %B := B..._j-    in f A_i)-  [|[|1, 1|], [|1, 1|]|]_i_j--assertEqual-  "generate_tensor by using function expr"-  (let g := generateTensor (\match as (integer, integer) with-              | ($n, #n) -> function (x, y, z)-              | (_, _) -> 0) [3, 3]-    in show (withSymbols [i, j] d/d g_i_j x))-  "[| [| g_1_1|x, 0, 0 |], [| 0, g_2_2|x, 0 |], [| 0, 0, g_3_3|x |] |]"--assertEqual-  "define tensor having value of function expr"-  (let g := [|[|function (x, y, z), 0, 0|]-            , [|0, function (x, y, z), 0|]-            , [|0, 0, function (x, y, z)|]|]-    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 |] |]"
− nons-test/test/poker-joker.egi 
@@ -1,37 +0,0 @@-suit := algebraicDataMatcher-  | spade-  | heart-  | club-  | diamond--card := matcher-  | card $ $ as (suit, mod 13) with -    | Card $s $n -> [(s, n)]-    | Joker -> matchAll ([Spade, Heart, Club, Diamond], [1..13])-                     as (set suit, set integer) with-               | ($s :: _, $n :: _) -> (s, n)-  | $ as something with-    | $tgt -> [tgt]--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"-  | card _ $n :: card _ #n :: card _ #n :: card _ #n :: _ :: []-    -> "Four of a kind"-  | card _ $m :: card _ #m :: card _ #m :: card _ $n :: card _ #n :: []-    -> "Full house"-  | card $s _ :: card #s _ :: card #s _ :: card #s _ :: card #s _ :: []-    -> "Flush"-  | card _ $n :: card _ #(n-1) :: card _ #(n-2) :: card _ #(n-3) :: card _ #(n-4) :: []-    -> "Straight"-  | card _ $n :: card _ #n :: card _ #n :: _ :: _ :: []-    -> "Three of a kind"-  | card _ $m :: card _ #m :: card _ $n :: card _ #n :: _ :: []-    -> "Two pair"-  | card _ $n :: card _ #n :: _ :: _ :: _ :: []-    -> "One pair"-  | _ :: _ :: _ :: _ :: _ :: [] -> "Nothing"--assertEqual "poker-joker" (poker [Card Spade 5, Card Spade 6, Joker, Card Spade 8, Card Spade 9]) "Straight flush"-assertEqual "poker-joker" (poker [Card Spade 5, Card Diamond 5, Joker, Card Club 5, Card Heart 7]) "Four of a kind"
− nons-test/test/poker.egi 
@@ -1,39 +0,0 @@-suit := algebraicDataMatcher-  | spade-  | heart-  | club-  | diamond--card := algebraicDataMatcher-  | card suit (mod 13)--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"-  | card _ $n :: card _ #n :: card _ #n :: card _ #n :: _ :: []-    -> "Four of a kind"-  | card _ $m :: card _ #m :: card _ #m :: card _ $n :: card _ #n :: []-    -> "Full house"-  | card $s _ :: card #s _ :: card #s _ :: card #s _ :: card #s _ :: []-    -> "Flush"-  | card _ $n :: card _ #(n-1) :: card _ #(n-2) :: card _ #(n-3) :: card _ #(n-4) :: []-    -> "Straight"-  | card _ $n :: card _ #n :: card _ #n :: _ :: _ :: []-    -> "Three of a kind"-  | card _ $m :: card _ #m :: card _ $n :: card _ #n :: _ :: []-    -> "Two pair"-  | card _ $n :: card _ #n :: _ :: _ :: _ :: []-    -> "One pair"-  | _ :: _ :: _ :: _ :: _ :: [] -> "Nothing"---assertEqual "poker" (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Spade 9])    "Straight flush"-assertEqual "poker" (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 5])   "Four of a kind"-assertEqual "poker" (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 7])   "Full house"-assertEqual "poker" (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 13, Card Spade 9])   "Flush"-assertEqual "poker" (poker [Card Spade 5, Card Club 6, Card Spade 7, Card Spade 8, Card Spade 9])     "Straight"-assertEqual "poker" (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 8])   "Three of a kind"-assertEqual "poker" (poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 10]) "Two pair"-assertEqual "poker" (poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 8])  "One pair"-assertEqual "poker" (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Diamond 11]) "Nothing"
− nons-test/test/primitive.egi 
@@ -1,175 +0,0 @@-assertEqual "numerator" (numerator (13 / 21)) 13--assertEqual "denominator" (denominator (13 / 21)) 21--assertEqual "modulo" (modulo (-21) 13) 5--assertEqual "quotient" (quotient (-21) 13) (-1)--assertEqual "remainder" (remainder (-21) 13) (-8)--assertEqual "neg" (neg (-89)) 89--assertEqual "abs" (abs 0)     0-assertEqual "abs" (abs 15)    15-assertEqual "abs" (abs (-89)) 89--assertEqual "lt?" (0.1 < 1.0) True-assertEqual "lt?" (1.0 < 0.1) False-assertEqual "lt?" (1.0 < 1.0) False--assertEqual "lte?" (0.1 <= 1.0) True-assertEqual "lte?" (1.0 <= 0.1) False-assertEqual "lte?" (1.0 <= 1.0) True--assertEqual "gt?" (0.1 > 1.0) False-assertEqual "gt?" (1.0 > 0.1) True-assertEqual "gt?" (1.0 > 1.0) False--assertEqual "gte?" (0.1 >= 1.0) False-assertEqual "gte?" (1.0 >= 0.1) True-assertEqual "gte?" (1.0 >= 1.0) True--assertEqual "round" (round 3.1)    3-assertEqual "round" (round 3.7)    4-assertEqual "round" (round (-2.2)) (-2)-assertEqual "round" (round (-2.7)) (-3)--assertEqual "floor" (floor 3.1)    3-assertEqual "floor" (floor 3.7)    3-assertEqual "floor" (floor (-2.2)) (-3)-assertEqual "floor" (floor (-2.7)) (-3)--assertEqual "ceiling" (ceiling 3.1)    4-assertEqual "ceiling" (ceiling 3.7)    4-assertEqual "ceiling" (ceiling (-2.2)) (-2)-assertEqual "ceiling" (ceiling (-2.7)) (-2)--assertEqual "truncate" (truncate 3.1)    3-assertEqual "truncate" (truncate 3.7)    3-assertEqual "truncate" (truncate (-2.2)) (-2)-assertEqual "truncate" (truncate (-2.7)) (-2)--assertEqual "sqrt" (sqrt 4) 2-assertEqual "sqrt" (sqrt 4.0) 2.0--- assertEqual "sqrt" (sqrt (-1)) i---- assertEqual "exp"---   [exp 1, exp 1.0, exp (-1.0)]---   [e, 2.718281828459045, 0.36787944117144233]---- assertEqual "log"---   [log e, log 10.0]---   [1, 2.302585092994046]---- TODO: trigonometric functions--- * sin--- * cos--- * tan--- * asin--- * acos--- * sinh--- * cosh--- * tanh--- * asinh--- * acosh--- * atanh---- tensorSize--- tensorToList--- dfOrder--assertEqual "itof" (itof 4)    4.0-assertEqual "itof" (itof (-1)) (-1.0)--assertEqual "rtof" (rtof (3 / 2)) 1.5-assertEqual "rtof" (rtof 1)       1.0--assertEqual "ctoi" (ctoi '1') 49--assertEqual "itoc" (itoc 49) '1'--assertEqual "pack" (pack []) ""-assertEqual "pack" (pack ['E', 'g', 'i', 's', 'o', 'n']) "Egison"--assertEqual "unpack" (unpack "Egison") ['E', 'g', 'i', 's', 'o', 'n']-assertEqual "unpack" (unpack "") []--assertEqual "unconsString" (unconsString "Egison") ('E', "gison")--assertEqual "lengthString" (lengthString "") 0-assertEqual "lengthString" (lengthString "Egison") 6--assertEqual "appendString" (appendString "" "")       ""-assertEqual "appendString" (appendString "" "Egison") "Egison"-assertEqual "appendString" (appendString "Egison" "") "Egison"-assertEqual "appendString" (appendString "Egi" "son") "Egison"--assertEqual "splitString" (splitString "," "") [""]-assertEqual "splitString" (splitString "," "2,3,5,7,11,13") ["2", "3", "5", "7", "11", "13"]--assertEqual "regex" (regex "cde" "abcdefg") [("ab", "cde", "fg")]-assertEqual "regex" (regex "[0-9]+" "abc123defg") [("abc", "123", "defg")]-assertEqual "regex" (regex "a*" "") [("", "", "")]--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-assertEqual "read" (read "{1 2}")            [1, 2]-assertEqual "read" (read "\"Hello world!\"") "Hello world!"---- TODO: read-tsv--assertEqual "show" (show 3)              "3"-assertEqual "show" (show 3.14159)        "3.14159"-assertEqual "show" (show [1, 2])         "[1, 2]"-assertEqual "show" (show "Hello world!") "\"Hello world!\""---- TODO: show-tsv--assertEqual "empty?" (empty? [])  True-assertEqual "empty?" (empty? [1]) False--assertEqual "uncons" (uncons [1, 2, 3]) (1, [2, 3])-assertEqual "unsnoc" (unsnoc [1, 2, 3]) ([1, 2], 3)--assertEqual "bool?" (bool? False) True--assertEqual "integer?" (integer? 1) True--assertEqual "rational?" (rational? 1)       True-assertEqual "rational?" (rational? (1 / 2)) True-assertEqual "rational?" (rational? 3.1)     False--assertEqual "scalar?" (scalar? 1) True-assertEqual "scalar?" (scalar? (| 1, 2 |)) False--assertEqual "float?" (float? 1.0) True-assertEqual "float?" (float? 1)   False--assertEqual "char?" (char? 'c') True--assertEqual "string?" (string? "hoge") True--assertEqual "collection?" (collection? []) True-assertEqual "collection?" (collection? [1]) True--assertEqual "array?" (array? (| |)) True-assertEqual "array?" (array? (| 1, 2, 3 |)) True--assertEqual "hash?" (hash? {| |}) True-assertEqual "hash?" (hash? {| (1, 2) |}) True---- TODO: Add a test case where tensor? returns True-assertEqual "tensor?" (tensor? 1)                           False-assertEqual "tensor?" (tensor? (| 1 |))                     False-assertEqual "tensor?" (tensor? [| 1 |])                     True-assertEqual "tensor?" (tensor? (generateTensor (+) [1, 2])) True---- TODO: tensorWithIndex?
− nons-test/test/syntax.egi 
@@ -1,628 +0,0 @@------ Syntax test---------- Primitive Data-----assertEqual "char literal"-  ['a', '\n', '\'']-  ['a', '\n', '\'']--assertEqual "string literal" "" ""-assertEqual "string literal" "abc\n" "abc\n"--assertEqual "bool literal"-  [True, False]-  [True, False]--assertEqual "integer literal"-  [1, 0, -100, 1 - 100]-  [1, 0, -100, -99]--assertEqual "rational number"-  [10 / 3, 10 / 20, -1 / 2]-  [10 / 3 , 1 / 2, -1 / 2]--assertEqual "float literal" [1.0, 0.0, -100.012001, 1.0 + 2] [1.0, 0.0, -100.012001, 3.0]--assertEqual "inductive data literal" A A--assertEqual "tuple literal" (1, 2, 3) (1, 2, 3)--assertEqual "collection literal" [1, 2, 3, 4, 5, 6] [1, 2, 3, 4, 5, 6]--assertEqual "collection between" [1..5] [1, 2, 3, 4, 5]-assertEqual "collection from" (take 5 [1..]) [1, 2, 3, 4, 5]------- Basic Sytax-----assertEqual "if"-  (if True then True else False)-  True--assertEqual "if"-  (if False then True else False)-  False--assertEqual "let binding"-  (let t := (1, 2)-       (x, y) := t-    in x + y)-  3--assertEqual "let binding"-  (let x := 1-       y := x + 1-    in y)-  2--assertEqual "let binding without newline"-  (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 without newline"; return 0 }--assertEqual "where"-  (f 0 + y + 1-    where f x := 2 + x-          y := 3)-  6--assertEqual "nested where"-  (f 0 + 1-    where-      f x := 2 + y + z-        where y := 3-      z := 4)-  10--assertEqual "multiple where in one expression"-  (matchAll [1, 2, 3] as multiset integer with-   | #1 :: $xs -> f xs-     where f xs := length xs-   | #2 :: #3 :: $xs -> g xs-     where g xs := length xs)-  [2, 1]--assertEqual "mutual recursion"-  (let even? n := if n = 0 then True else odd? (n - 1)-       odd?  n := if n = 0 then False else even? (n - 1)-    in even? 10)-  True--assertEqual "lambda and application"-  ((\x -> x + 1) 10)-  11--assertEqual "application with binops"-  ((\x y -> x + y) 1 2 + 3)-  6--assertEqual "append op" ([1] ++ [2]) [1, 2]-assertEqual "append op" ((++) [1] [2]) [1, 2]--assertEqual "apply op" ((+ 5) $ 1 + 2) 8--assertEqual "section" ((+) 10 1) 11-assertEqual "section" ((+ 1) 10) 11-assertEqual "section" (foldl (*) 1 [1..5]) 120-assertEqual "section" ((-) 10 1) 9-assertEqual "section" ((10 -) 1) 9-assertEqual "section" ((10 - ) 1) 9-assertEqual "section" ((-1 +) 2) 1-assertEqual "safe section - left assoc"  ((1 + 2 +) 3) 6-assertEqual "safe section - right assoc" ((++ [1] ++ [2]) [3]) [3, 1, 2]-assertEqual "not section" (- 2) (1 - 3)---- user-defined infix-infixl expression 5 @-(@) x y := x - y--assertEqual "user defined infix"-  (4 @ 3 @ 5)-  (-4)--infixl expression 5 @@-(@@) %x y := x - y--assertEqual "user defined infix with tensor arg"-  (4 @@ 3 @@ 2)-  (-1)--findFactor :=-  memoizedLambda n ->-    match takeWhile (<= floor (sqrt (itof n))) primes as list integer with-    | _ ++ (?(\m -> divisor? n m) & $x) :: _ -> x-    | _ -> n--assertEqual "memoized lambda"-  (map findFactor [1..10])-  [1, 2, 3, 2, 5, 2, 7, 2, 3, 2]--twinPrimes :=-  matchAll primes as list integer with-  | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2)--assertEqual "twin primes"-  (take 10 twinPrimes)-  [(3, 5), (5, 7), (11, 13), (17, 19), (29, 31), (41, 43), (59, 61), (71, 73), (101, 103), (107, 109)]--primeTriplets :=-  matchAll primes as list integer with-  | _ ++ $p :: ((#(p + 2) | #(p + 4)) & $m) :: #(p + 6) ::  _-  -> (p, m, p + 6)--assertEqual "prime triplets"-  (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 :=-  x + y * z--assertEqual "function definition"-  (someFunction 1 2 3)-  7--someFunctionWithDollar $x $y $z :=-  x + y + z--assertEqual "function definition with '$' scalar arg"-  (someFunctionWithDollar 1 2 3)-  6--gcd m n :=-  if m >= n then-            if n = 0 then m-                     else gcd n (m % n)-            else gcd n m--assertEqual "recursive function definition"-  (gcd 143 22)-  11--A x := 1--assertEqual "definition of upper-case identifier"-  (A 2)-  1--assertEqual "capply"-  (capply (+) [1, 2])-  3--{--  This is a comment- -}--{--  {- We can nest comments! -}-  {- {- nested -} comment -}- -}------- Pattern-Matching-----assertEqual "match"-  (match 1 as integer with-   | #0 -> 0-   | $x -> 10 + x)-  11--assertEqual "match-all"-  (matchAll [1, 2, 3] as multiset integer with-   | $x :: _ -> x)-  [1, 2, 3]--assertEqual "match-all-multi"-  (matchAll [1, 2, 3] as multiset integer with-   | $x :: #(x + 1) :: _ -> [x, x + 1]-   | $x :: #(x + 2) :: _ -> [x, x + 2])-  [[1, 2], [2, 3], [1, 3]]--assertEqual "match-lambda"-  ((\match as list integer with-    | [] -> 0-    | $x :: _ -> x) [1, 2, 3])-  1--assertEqual "match-all-lambda"-  ((\matchAll as list something with-    | _ ++ $x :: _ -> x) [1, 2, 3])-  [1, 2, 3]--assertEqual "match-all-lambda-multi"-  ((\matchAll as multiset something with-    | $x :: #(x + 1) :: _ -> [x, x + 1]-    | $x :: #(x + 2) :: _ -> [x, x + 2]) [1, 2, 3])-  [[1, 2], [2, 3], [1, 3]]--assert "nested pattern match"-  (match [1, 2, 3] as list integer with-   | #2 :: $x -> match x as multiset integer with-                | _ -> False-   | #1 :: $x -> match x as multiset integer with-                | #1 :: _ -> False-                | #2 :: _ -> True)--assertEqual "pattern variable"-  (match 1 as something with $x -> x)-  1--assert "value pattern" (match 1 as integer with #1 -> True)--assert "inductive pattern"-  (match [1, 2, 3] as list integer with-   | snoc #3 _ -> True)--assert "and pattern"-  (match [1, 2, 3] as list integer with-   | #1 :: _ & snoc #3 _ -> True)--assert "and pattern"-  (match [1, 2, 3] as list integer with-   | #1 :: _ & #3 :: _ -> False-   | _ -> True)--assert "or pattern"-  (match [1, 2, 3] as list integer with-   | snoc #1 _ | snoc #3 _ -> True)--assert "or pattern"-  (match [1, 2, 3] as list integer with-   | #2 :: _ | #1 :: _ -> True)--assert "not pattern"-  (match [1, 2] as list integer with-   | snoc !#1 _ -> True-   | !#1 :: _ -> False)--assertEqual "not pattern"-  (matchAll [1, 2, 2, 3, 3, 3] as multiset integer with-   | $n :: !(#n :: _) -> n)-  [1]--assert "predicate pattern"-  (match [1, 2, 3] as list integer with-   | ?(= 1) :: _ -> True)--assert "predicate pattern"-  (match [1, 2, 3] as list integer with-   | ?(= 2) :: _ -> False-   | _ -> True)--assertEqual "indexed pattern variable"-  (match 23 as mod 10 with-   | $a_1 -> a)-  {| (1, 23) |}--assert "loop pattern"-  (match [3, 2, 1] as list integer with-   | loop $i (1, [3], _)-       (snoc #i ...)-       [] -> True)--assertEqual "loop pattern"-  (match [1..10] as list integer with-   | loop $i (1, $n)-       (#i :: ...)-       [] -> n)-  10--assert "loop pattern"-  (match [3, 2, 1] as list integer with-   | loop $i (1, [3], _)-       (snoc #i ...)-       [] -> True)--assertEqual "double loop pattern"-  (match [[1, 2, 3], [4, 5, 6], [7, 8, 9]] as (list (list integer)) with-   | loop $i (1, [3], _)-       ((loop $j (1, [3], _)-           ($n_i_j :: ...)-           []) :: ...)-       [] -> n)-  {| (1, {| (1, 1), (2, 2), (3, 3) |}),-     (2, {| (1, 4), (2, 5), (3, 6) |}),-     (3, {| (1, 7), (2, 8), (3, 9) |}) |}--assertEqual "let pattern"-  (match [1, 2, 3] as list integer with-   | let a := 42 in _ -> a)-  42--assertEqual "let pattern"-  (match [1, 2, 3] as list integer with-   | $a :: (let x := a in $xs) -> [x, xs])-  [1, [2, 3]]--assertEqual "let pattern"-  (match [1, 2, 3] as list integer with-   | $a & (let n := length a in _) -> [a, n])-  [[1, 2, 3], 3]--assertEqual "tuple pattern"-  (matchAll (1, (2, 3)) as (integer, (integer, integer)) with-   | ($m, ($n, $w)) -> [m, n, w])-  [[1, 2, 3]]--assertEqual "tuple pattern"-  (matchAll [(1, 1), (2, 2)] as multiset (integer, integer) with-   | ($x, #x) :: _ -> x)-  [1, 2]--assertEqual "pattern function call"-   (let twin := \pat1 pat2 => (~pat1 & $x) :: #x :: ~pat2 in-    match [1, 1, 1, 2, 3] as list integer with-    | twin $n $ns -> [n, ns])-   [1, [1, 2, 3]]--assertEqual "recursive pattern function call"-  (let repeat := \pat => [] | ~pat :: (repeat ~pat) in-   matchAll [1, 1, 1, 1] as list integer with-   | repeat #1 -> "OK")-  ["OK"]--assertEqual "loop pattern in pattern function"-  (let comb n := \p =>-     loop $i (1, n, _) (_ ++ ~p_i :: ...) _-    in-    matchAll [1, 2, 3, 4, 5] as (list integer) with-    | (comb 2) $n -> n)-  [{|(1, 1), (2, 2)|}, {|(1, 1), (2, 3)|},-   {|(1, 2), (2, 3)|}, {|(1, 1), (2, 4)|},-   {|(1, 2), (2, 4)|}, {|(1, 3), (2, 4)|},-   {|(1, 1), (2, 5)|}, {|(1, 2), (2, 5)|},-   {|(1, 3), (2, 5)|}, {|(1, 4), (2, 5)|}]--assertEqual "pairs of 2, natural numbers"-  (take 10 (matchAll nats as set integer with-            | $m :: $n :: _ -> [m, n]))-  [[1, 1], [1, 2], [2, 1], [1, 3], [2, 2], [3, 1], [1, 4], [2, 3], [3, 2], [4, 1]]--assertEqual "pairs of 2, different natural numbers"-  (take 10 (matchAll nats as list integer with-            | _ ++ $m :: _ ++ $n :: _ -> [m, n]))-  [[1, 2], [1, 3], [2, 3], [1, 4], [2, 4], [3, 4], [1, 5], [2, 5], [3, 5], [4, 5]]--assertEqual "combinations"-  (matchAll [1,2,3] as list something with-   | _ ++ $x :: _ ++ $y :: _ -> (x, y))-  [(1, 2), (1, 3), (2, 3)]--assertEqual "permutations"-  (matchAll [1,2,3] as multiset something with-   | $x :: $y :: _ -> (x, y))-  [(1, 2), (1, 3), (2, 1), (2, 3), (3, 1), (3, 2)]--tree a := algebraicDataMatcher-  | leaf-  | node (tree a) a (tree a)--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-      | less    -> Node (treeInsert n t1) m t2-      | equal   -> Node t1 n t2-      | greater -> Node t1 m (treeInsert n t2)--treeMember? n t :=-  match t as tree integer with-  | leaf -> False-  | node $t1 $m $t2 -> match (compare n m) as ordering with-      | less    -> treeMember? n t1-      | equal   -> True-      | greater -> treeMember? n t2--assertEqual "tree set using algebraic-data-matcher"-  (let t := foldr treeInsert Leaf [4, 1, 2, 4, 3]-    in [treeMember? 1 t, treeMember? 0 t])-  [True, False]--assert "sequential pattern"-  (match [2,3,1,4,5] as list integer with-   | { @ :: @ :: $x :: _,-       (#(x + 1), @),-      #(x + 2)}-   -> True)--assertEqual "sequential not pattern"-  (matchAll ([1,2,3], [4,3,5]) as (multiset eq, multiset eq) with-   | { ($x :: @, #x :: @),-       !($y :: _, #y :: _) }-   -> x)-  [3]--assertEqual "partial sequential pattern"-  (matchAll ([1,2,3,2], [10,20]) as (list eq, list eq) with-   | ({ @ ++ $x :: _, !(_ ++ #x :: _) }, $ys) -> (x, ys))-  [(1, [10, 20]), (2, [10, 20]), (3, [10, 20])]--assertEqual "forall pattern 1"-  (matchAll [1,5,3] as multiset integer with-   | forall _ _ -> "ok")-  ["ok"]--assertEqual "forall pattern 2"-  (matchAll [1,5,3] as multiset integer with-   | (forall ((@ & $x) :: _) ?odd?) & $xs -> (x,xs))-  [(1, [1, 5, 3]), (5, [1, 5, 3]), (3, [1, 5, 3])]--assertEqual "forall pattern 3"-  (matchAllDFS [1,5,3] as multiset integer with-   | forall ((@ & $x) :: _) ?odd? -> x)-  [1,5,3]--assertEqual "forall pattern 4"-  (matchAll [1,5,3] as multiset integer with-   | forall ((@ & $x) :: _) ?odd? -> x)-  [1, 5, 3]------- Tensor-----assertEqual "generate-tensor"-  (generateTensor (*) [3, 5])-  [| [| 1, 2, 3, 4, 5 |], [| 2, 4, 6, 8, 10 |], [| 3, 6, 9, 12, 15 |] |]--assertEqual "tensor"-  (tensor [2, 5] [1, 2, 3, 4, 5, 2, 4, 6, 8, 10])-  [| [| 1, 2, 3, 4, 5 |], [| 2, 4, 6, 8, 10 |] |]--assertEqual "tensor wedge expr"-  (! b.min [| 1, 2, 3 |] [| 1, 2, 3 |])-  [| [| 1, 1, 1 |], [| 1, 2, 2 |], [| 1, 2, 3 |] |]--assertEqual "tensor wedge expr of binary operator"-  ([| 1, 2, 3 |] !+ [| 1, 2, 3 |])-  [| [| 2, 3, 4 |], [| 3, 4, 5 |], [| 4, 5, 6 |] |]--assertEqual "tensor wedge expr of binary operator - section style"-  ((!+) [| 1, 2, 3 |] [| 1, 2, 3 |])-  [| [| 2, 3, 4 |], [| 3, 4, 5 |], [| 4, 5, 6 |] |]--assertEqual "tensor multiplication"-  ([| 1, 2, 3 |]_i * [| 1, 2, 3 |]_i)-  [| 1, 4, 9 |]_i--assertEqual "multi subscript"-  (let i := {| (1, 1), (2, 2), (3, 3) |}-       x := generateTensor (\x y z -> x + y + z) [5, 5, 5]-    in x_(i_1)..._(i_3))-  6------- Hash-----assertEqual "hash-literal"-  {| (1, 11), (2, 12), (3, 13), (4, 14), (5, 15), |}-  {| (1, 11), (2, 12), (3, 13), (4, 14), (5, 15), |}--assertEqual "empty hash-literal"-  {| |}-  {| |}--assertEqual "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------- Partial Application-----assertEqual "partial application '#'"-  (2#(10 * %1 + %2) 1 2)-  12---- assertEqual "recursive partial application '#'"---   (take 10 (1#(%1 :: (%0 (%1 * %2))) 2))---   [2, 4, 8, 16, 32, 64, 128, 256, 512, 1024]--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--assertEqual "single inverted index"-  (g [|1, 2, 3|]_i  [|10, 20, 30|]_j)-  [| [| 11, 21, 31, |], [| 12, 22, 32, |], [| 13, 23, 33, |], |]_i~j------- matcherExpr-----list a := matcher-  | [] as () with-    | [] -> [()]-    | _  -> []-  | $ :: $    as (a, list a) with-    | $x :: $xs -> [(x, xs)]-    | _         -> []-  | snoc $ $ as (a, list a) with-    | snoc $xs $x -> [(x, xs)]-    | _           -> []-  | _ ++ $ as (list a) with-    | $tgt -> matchAll tgt as list a with-              | loop $i (1, _) (_ :: ...) $rs -> rs-  | $ ++ $ as (list a, list a) with-    | $tgt -> matchAll tgt as list a with-              | loop $i (1, $n) ($xa_i :: ...) $rs ->-                (foldr (\%i %r -> xa_i :: r) [] [1..n], rs)-  | nioj $ $ as (list a, list a) with-    | $tgt -> matchAll tgt as list a with-              | loop $i (1, $n) (snoc $xa_i ...) $rs ->-                (foldr (\%i %r -> r ++ [xa_i]) [] [1..n], rs)-  | #$val as () with-    | $tgt -> if val = tgt then [()] else []-  | $ as something with-    | $tgt -> [tgt]--multiset a := matcher-  | [] as () with-    | $tgt -> match tgt as (mutiset a) with-                | [] -> [()]-                | _ -> []-  | $ :: $ as (a, multiset a) with-    | $tgt -> matchAll tgt as list a with-                | $hs ++ $x :: $ts -> (x, hs ++ ts)-  | #$val as () with-    | $tgt -> match (val, tgt) as (list a, multiset a) with-                | ([], []) -> [()]-                | ($x :: $xs, #x :: #xs) -> [()]-                | (_, _) -> []-  | $ as something with-    | $tgt -> [tgt]--assertEqual "matcher definition"-  (matchAll [1, 2, 3] as multiset integer with-   | $x :: _ -> x)-  [1, 2, 3]--nishiwakiIf b e1 e2 :=-  car (matchAll b as (matcher-                      | $ as something with-                          | True  -> [e1]-                          | False -> [e2]) with-       | $x -> x)--assertEqual "case 1" (nishiwakiIf True     1 2) 1-assertEqual "case 2" (nishiwakiIf False    1 2) 2-assertEqual "case 3" (nishiwakiIf (1 = 1) 1 2) 1---- User-defined pattern infix--infixl pattern 7 <>-infixl pattern 4 <?> -- '?' is allowed from the 2nd character--dummyMatcher := matcher-  | $ <> $ as (integer, integer) with-    | $x :: $y :: [] -> [(x, y)]-    | _              -> []-  | $ <?> $ as (integer, list integer) with-    | $x :: $xs -> [(x, xs)]-    | _         -> []--assertEqual "user-defined pattern infix"-  (match [1, 2] as dummyMatcher with $x <> $y -> x + y)-  3--assertEqual "user-defined pattern infix"-  (match [1, 2] as dummyMatcher with $x <?> $y :: _ -> x + y)-  3
− sample/bellman-ford.egi 
@@ -1,19 +0,0 @@-; initiate a distance graph-(define $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 |]|])--(define $G.* (lambda [%t1 %t2] (with-symbols {i} (contract min (+ t1~#_i t2~i_#)))))--(match (iterate (lambda [%P] (G.* P A)) A) (list something)-  {[<join _ <cons $P <cons ,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/binary-counter.egi 
@@ -1,3 +0,0 @@-(define $bc (match-all {0 1} (set integer) [(loop $i [1 $n] <cons $x_i ...> _) (map (lambda [$i] x_i) (between 1 n))]))--(take 30 bc)
− sample/bipartite-graph.egi 
@@ -1,87 +0,0 @@-;;;-;;;-;;; Bipartite Graph demonstartion-;;;-;;;--;;-;; Matcher definitions-;;-(define $bipartite-graph-  (lambda [$a $b]-    (multiset (edge a b))))--(define $edge-  (lambda [$a $b]-    (algebraic-data-matcher-      {<edge a b>})))--;;-;; Demonstration code-;;-(define $bipartite-graph-data-  {<Edge 1 "a">-   <Edge 1 "a">-   <Edge 1 "a">-   <Edge 1 "a">-   <Edge 1 "b">-   <Edge 1 "c">-   <Edge 2 "a">-   <Edge 2 "a">-   <Edge 2 "a">-   <Edge 2 "a">-   <Edge 2 "a">-   <Edge 3 "c">-   <Edge 4 "a">-   <Edge 5 "a">-   <Edge 5 "b">-   <Edge 5 "c">-   <Edge 6 "c">-   <Edge 6 "c">-   <Edge 6 "c">-   })--(test (match-all bipartite-graph-data (bipartite-graph integer string)-        [<cons <edge ,1 $str> _> str]))--(test (unique/m integer-                (match-all bipartite-graph-data (bipartite-graph integer string)-                  [<cons <edge $n $str>-                         <cons <edge ,n ,str>-                               !<cons <edge ,n !,str> _>>>-                   n])))--(test (unique/m integer-                (match-all bipartite-graph-data (bipartite-graph integer string)-                  [<cons <edge $n $str>-                         <cons <edge ,n ,str>-                               !<cons <edge ,n !,str> _>>>-                   n])))--(test (unique/m integer-                (match-all bipartite-graph-data (bipartite-graph integer string)-                  [<cons <edge $n ,"a"> _>-                   n])))--(test (unique/m integer-                (match-all bipartite-graph-data (bipartite-graph integer string)-                  [<cons <edge $n ,"a">-                    <cons <edge ,n ,"c">-                     _>>-                   n])))--;; I found bug on nested not-patterns-;(test (unique/m integer-;                (match-all bipartite-graph-data (bipartite-graph integer string)-;                  [(& <cons <edge $n $str>-;                            <cons <edge ,n ,str>-;                                  <cons <edge ,n ,str> _>>>-;                      !<cons <edge $n2 $str2>-;                             !<cons <edge ,n2 ,str2> _>>)-;                   n])))--(test (unique/m integer-                (match-all bipartite-graph-data (bipartite-graph integer string)-                  [<cons <edge $n2 $str2>-                         !<cons <edge ,n2 ,str2> _>>-                  n2])))
+ sample/chopsticks.egi view
@@ -0,0 +1,169 @@+assocMultiset a := matcher+  | [] as () with+    | [] -> [()]+    | _  -> []+  | #$x :: $ as assocMultiset a with+    | $tgt -> match tgt as list (a, integer) with+              | $hs ++ (#x, #1) :: $ts -> hs ++ ts+              | $hs ++ (#x, $n) :: $ts -> hs ++ (x, n - 1) :: ts+  | $ :: $ as (a, assocMultiset a) with+    | $tgt -> matchAll tgt as list (a, integer) with+              | $hs ++ ($x, #1) :: $ts -> (x, hs ++ ts)+              | $hs ++ ($x, !#1 & $n) :: $ts -> (x, hs ++ (x, n - 1) :: ts)+  | $ as something with+    | $tgt -> [tgt]++assertEqual "assocMultiset"+  (matchAll [(1,2),(2,1),(3,3)] as assocMultiset integer with+   | #1 :: $rs -> rs)+  [(1, 1), (2, 1), (3, 3)]++assertEqual "assocMultiset"+  (matchAll [(1,2),(2,1),(3,3)] as assocMultiset integer with+   | #2 :: $rs -> rs)+  [(1, 2), (3, 3)]++assertEqual "assocMultiset"+  (matchAll [(1,2),(2,1),(3,3)] as assocMultiset integer with+   | $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+  | _ ++ ($x, $n) :: _ -> take n (repeat1 x))++assertEqual "assocToList"+  (assocToList [(1,2),(2,1),(3,3)])+  [1, 1, 2, 3, 3, 3]++N := 5++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)++fOrS s := match s as state with+  | ($h, _, _) -> h++transformState s := match s as state with+  | ($h, $x, $y) -> (h, assocToList x, assocToList y)++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')+  -- the single hand becomes more than N+  | (#1, ($s1 & $x :: _), ?(\y -> x + y > N) :: [])+    -> (-1, s1, [])+  -- a hand becomes more than N+  | (#1, ($s1 & $x :: _), (?(\y -> x + y > N) & $y) :: (![] & $rs'))+    -> (2, s1, rs')+  -- equal or less than N+  | (#2, $x :: $rs', (?(\y -> x + y < N + 1) & $y) :: _ & $s2)+    -> (1, add (x + y) rs', s2)+  -- the single hand becomes more than N+  | (#2, $x :: [], (?(\y -> x + y > N) :: _) & $s2)+    -> (-2, [], s2)+  -- a hand becomes more than N+  | (#2, $x :: (![] & $rs'), (?(\y -> x + y > N) :: _) & $s2)+    -> (1, rs', s2)++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+++"move"+move (1, [(2,1)], [(1,1), (5,1)]) -- [(2, [(2, 1)], [(3, 1), (5, 1)]), (2, [(2, 1)], [(1, 1)])]+move (2, [(1,1), (5,1)], [(2,1)]) -- [(1, [(3, 1), (5, 1)], [(2, 1)])]+++assertEqual "add"+  (add 1 [(1,3),(3,1)])+  [(1, 4), (3, 1)]++assertEqual "add"+  (add 2 [(1,3),(3,1)])+  [(1, 3), (2, 1), (3, 1)]++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))++assertEqual "makeTree"+  (makeTree (1, [(2, 1)], [(1, 1)]))+  (Node (1, [(2, 1)], [(1, 1)])+    [Node (2, [(2, 1)], [(3, 1)])+       [Node (1, [(5, 1)], [(3, 1)])+          [Node (-1, [(5, 1)], [])+             []]]])++topTree s n :=+  matchAllDFS makeTree s as tree state with+  | loop $i (1, [1..n], $m)+      (node $x_i (... :: _))+      _+  -> map (\i -> x_i) [1..m]+++paths :=+  matchAllDFS makeTree init as tree state with+  | loop $i (1, $n)+      (node $x_i (... :: _))+      (node $x_(n + 1) [])+  -> map (\i -> x_i) [1..(n + 1)]++--io (each (compose show print) (head paths))++winningRec s :=+  matchAll makeTree s as tree state with+  | (node ($h, _, _)+         ((node ($t & ((#(neg h), _, _)+                    | ?(\t -> (empty? (winningRec t))))) _)+          :: _))+  -> t++winningNot s :=+  matchAllDFS makeTree s as tree state with+  | node ($h, _, _)+      (loop $i (1, [1..], _)+         (node $t !(node _ !... :: _) :: _)+         (node (#(neg h), _, _) _ :: _))+  -> t++winning c :=+  matchAllDFS makeTree c as tree state with+  | node ($h, _, _)+      (loop $i (1, $n)+         (node $f_i (forall (@ :: _)+                            (node $s_i ...)) :: _)+         (node ((#(neg h), _, _) & $l) _ :: _))+  -> c :: concat (map (\i -> [f_i, s_i]) [1..n]) ++ [l]++"winning (first)"+io (each (compose (\l -> (map transformState l)) (compose show print)) (winning init))++"winning (second)"+winning (2, [(1, 2)], [(2, 1), (1, 1)])++"winning"+winning (1, [(5, 2)], [(5, 1)])++"winning"+winning (1, [(2, 1)], [(1, 1)])++assertEqual "winningNot (first)"+  (winningNot init)+  [(2, [(1, 2)], [(2, 1), (1, 1)])]++assertEqual "winningNot (second)"+  (winningNot (2, [(1, 2)], [(2, 1), (1, 1)]))+  []
+ sample/chopsticks2.egi view
@@ -0,0 +1,51 @@+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], [])]+  ,[(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, [4], [5]), (-1, [4], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 4]), (1, [2, 5], [2, 4]), (2, [2, 5], [4]), (1, [2], [4]), (-1, [2], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 4]), (1, [2, 5], [2, 4]), (2, [2, 5], [4]), (1, [5], [4]), (-1, [5], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 4]), (1, [2], [2, 4]), (2, [2], [2]), (1, [4], [2]), (-1, [4], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 4]), (1, [3, 4], [2, 4]), (2, [3, 4], [4]), (1, [3], [4]), (-1, [3], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 4]), (1, [3, 4], [2, 4]), (2, [3, 4], [4]), (1, [4], [4]), (-1, [4], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 4]), (1, [3], [2, 4]), (2, [3], [2]), (1, [5], [2]), (-1, [5], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 5]), (1, [2, 5], [2, 5]), (2, [2, 5], [5]), (1, [2], [5]), (-1, [2], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 5]), (1, [2, 5], [2, 5]), (2, [2, 5], [5]), (1, [5], [5]), (-1, [5], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 5]), (1, [2], [2, 5]), (2, [2], [2]), (1, [4], [2]), (-1, [4], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 5]), (1, [3, 4], [2, 5]), (2, [3, 4], [5]), (1, [3], [5]), (-1, [3], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 5]), (1, [3, 4], [2, 5]), (2, [3, 4], [5]), (1, [4], [5]), (-1, [4], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 2], [1, 2]), (2, [1, 2], [2, 2]), (1, [2, 3], [2, 2]), (2, [2, 3], [2, 5]), (1, [3], [2, 5]), (2, [3], [2]), (1, [5], [2]), (-1, [5], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 3], [1, 2]), (2, [1, 3], [2, 2]), (1, [1, 5], [2, 2]), (2, [1, 5], [2]), (1, [1], [2]), (2, [1], [3]), (1, [4], [3]), (-1, [4], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 3], [1, 2]), (2, [1, 3], [2, 2]), (1, [1, 5], [2, 2]), (2, [1, 5], [2]), (1, [3, 5], [2]), (-1, [3, 5], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 3], [1, 2]), (2, [1, 3], [2, 2]), (1, [1, 5], [2, 2]), (2, [1, 5], [2]), (1, [3, 5], [2]), (2, [3, 5], [5]), (1, [3], [5]), (-1, [3], [])]+  ,[(1, [1, 1], [1, 1]), (2, [1, 1], [1, 2]), (1, [1, 3], [1, 2]), (2, [1, 3], [2, 2]), (1, [1, 5], [2, 2]), (2, [1, 5], [2]), (1, [3, 5], [2]), (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, 5], [2, 5]), (2, [3, 5], [5]), (1, [3], [5]), (-1, [3], [])]+  ,[(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++listToTree ps := matchDFS ps as list (list eq) with+  | [] :: [] -> []+  | loop $i (1, $m)+      (($x_i :: $r_i_1) :: (loop $j (2, $n_i)+                              ((#x_i :: $r_i_j) :: ...)+                              (!((#x_i :: _) :: _) & ...)))+      []+  -> map (\i -> Node x_i (listToTree (map (\j -> r_i_j) [1..(n_i)]))) [1..m]++listToTree [[1]]+++listToTree [[1,2],[1,3]]+++listToTree [[1,2,3],[1,2,4],[1,3]]+++listToTree [[1..10]]+++listToTree paths+-- [Node (1, [1, 1], [1, 1]) [Node (2, [1, 1], [1, 2]) [Node (1, [1, 2], [1, 2]) [Node (2, [1, 2], [2, 2]) [Node (1, [1, 4], [2, 2]) [Node (2, [1, 4], [2]) [Node (1, [1], [2]) [Node (2, [1], [3]) [Node (1, [4], [3]) [Node (-1, [4], []) []]]], Node (1, [3, 4], [2]) [Node (-1, [3, 4], []) [], Node (2, [3, 4], [5]) [Node (1, [3], [5]) [Node (-1, [3], []) []], Node (1, [4], [5]) [Node (-1, [4], []) []]]]]], Node (1, [2, 3], [2, 2]) [Node (2, [2, 3], [2, 4]) [Node (1, [2, 5], [2, 4]) [Node (2, [2, 5], [4]) [Node (1, [2], [4]) [Node (-1, [2], []) []], Node (1, [5], [4]) [Node (-1, [5], []) []]]], Node (1, [2], [2, 4]) [Node (2, [2], [2]) [Node (1, [4], [2]) [Node (-1, [4], []) []]]], Node (1, [3, 4], [2, 4]) [Node (2, [3, 4], [4]) [Node (1, [3], [4]) [Node (-1, [3], []) []], Node (1, [4], [4]) [Node (-1, [4], []) []]]], Node (1, [3], [2, 4]) [Node (2, [3], [2]) [Node (1, [5], [2]) [Node (-1, [5], []) []]]]], Node (2, [2, 3], [2, 5]) [Node (1, [2, 5], [2, 5]) [Node (2, [2, 5], [5]) [Node (1, [2], [5]) [Node (-1, [2], []) []], Node (1, [5], [5]) [Node (-1, [5], []) []]]], Node (1, [2], [2, 5]) [Node (2, [2], [2]) [Node (1, [4], [2]) [Node (-1, [4], []) []]]], Node (1, [3, 4], [2, 5]) [Node (2, [3, 4], [5]) [Node (1, [3], [5]) [Node (-1, [3], []) []], Node (1, [4], [5]) [Node (-1, [4], []) []]]], Node (1, [3], [2, 5]) [Node (2, [3], [2]) [Node (1, [5], [2]) [Node (-1, [5], []) []]]]]]]], Node (1, [1, 3], [1, 2]) [Node (2, [1, 3], [2, 2]) [Node (1, [1, 5], [2, 2]) [Node (2, [1, 5], [2]) [Node (1, [1], [2]) [Node (2, [1], [3]) [Node (1, [4], [3]) [Node (-1, [4], []) []]]], Node (1, [3, 5], [2]) [Node (-1, [3, 5], []) [], Node (2, [3, 5], [5]) [Node (1, [3], [5]) [Node (-1, [3], []) []], Node (1, [5], [5]) [Node (-1, [5], []) []]]]]], Node (1, [3, 3], [2, 2]) [Node (2, [3, 3], [2, 5]) [Node (1, [3, 5], [2, 5]) [Node (2, [3, 5], [5]) [Node (1, [3], [5]) [Node (-1, [3], []) []], Node (1, [5], [5]) [Node (-1, [5], []) []]]], Node (1, [3], [2, 5]) [Node (2, [3], [2]) [Node (1, [5], [2]) [Node (-1, [5], []) []]]]]]]]]]]+
+ sample/chopsticks3.egi view
@@ -0,0 +1,23 @@+[(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, [3, 4], [2]) [(-1, [3, 4], []) []+                                          |                                         |                                                       , (2, [3, 4], [5]) [(1, [3], [5]) [(-1, [3], []) []]+                                          |                                         |                                                                         , (1, [4], [5]) [(-1, [4], []) []]]]]]+                                          |                                        , (1, [2, 3], [2, 2]) [(2, [2, 3], [2, 4]) [(1, [2, 5], [2, 4]) [(2, [2, 5], [4]) [(1, [2], [4]) [(-1, [2], []) []]+                                          |                                                              |                    |                                     , (1, [5], [4]) [(-1, [5], []) []]]]+                                          |                                                              |                   , (1, [2], [2, 4]) [(2, [2], [2]) [(1, [4], [2]) [(-1, [4], []) []]]]+                                          |                                                              |                   , (1, [3, 4], [2, 4]) [(2, [3, 4], [4]) [(1, [3], [4]) [(-1, [3], []) []]+                                          |                                                              |                    |                                     , (1, [4], [4]) [(-1, [4], []) []]]]+                                          |                                                              |                   , (1, [3], [2, 4]) [(2, [3], [2]) [(1, [5], [2]) [(-1, [5], []) []]]]]+                                          |                                                             , (2, [2, 3], [2, 5]) [(1, [2, 5], [2, 5]) [(2, [2, 5], [5]) [(1, [2], [5]) [(-1, [2], []) []]+                                          |                                                                                   |                                     , (1, [5], [5]) [(-1, [5], []) []]]]+                                          |                                                                                  , (1, [2], [2, 5]) [(2, [2], [2]) [(1, [4], [2]) [(-1, [4], []) []]]]+                                          |                                                                                  , (1, [3, 4], [2, 5]) [(2, [3, 4], [5]) [(1, [3], [5]) [(-1, [3], []) []]+                                          |                                                                                   |                                     , (1, [4], [5]) [(-1, [4], []) []]]]+                                          |                                                                                  , (1, [3], [2, 5]) [(2, [3], [2]) [(1, [5], [2]) [(-1, [5], []) []]]]]]]]+                                         , (1, [1, 3], [1, 2]) [(2, [1, 3], [2, 2]) [(1, [1, 5], [2, 2]) [(2, [1, 5], [2]) [(1, [1], [2]) [(2, [1], [3]) [(1, [4], [3]) [(-1, [4], []) []]]]+                                                                                    |                                     , (1, [3, 5], [2]) [(-1, [3, 5], []) []+                                                                                                                                            , (2, [3, 5], [5]) [(1, [3], [5]) [(-1, [3], []) []]+                                                                                    |                                                                         , (1, [5], [5]) [(-1, [5], []) []]]]]]+                                                                                   , (1, [3, 3], [2, 2]) [(2, [3, 3], [2, 5]) [(1, [3, 5], [2, 5]) [(2, [3, 5], [5]) [(1, [3], [5]) [(-1, [3], []) []]+                                                                                                                              |                                     , (1, [5], [5]) [(-1, [5], []) []]]]+                                                                                                                             , (1, [3], [2, 5]) [(2, [3], [2]) [(1, [5], [2]) [(-1, [5], []) []]]]]]]]]]]
sample/demo1-ja.egi view
@@ -1,9 +1,8 @@-;; 素数の無限リストから全ての双子素数をパターンマッチにより抽出-(define $twin-primes-  (match-all primes (list integer)-    [<join _ <cons $p <cons ,(+ p 2) _>>>-     [p (+ p 2)]]))+-- 素数の無限リストから全ての双子素数をパターンマッチにより抽出+twinPrimes :=+  matchAll primes as list integer with+    | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2) -;; 最初の10個の双子素数を列挙-(take 10 twin-primes)-;=>{[3 5] [5 7] [11 13] [17 19] [29 31] [41 43] [59 61] [71 73] [101 103] [107 109]}+-- 最初の10個の双子素数を列挙+take 10 twinPrimes+-- => [(3, 5), (5, 7), (11, 13), (17, 19), (29, 31), (41, 43), (59, 61), (71, 73), (101, 103), (107, 109)]
sample/demo1.egi view
@@ -1,9 +1,8 @@-;; Extract all twin primes from the infinite list of prime numbers with pattern matching!-(define $twin-primes-  (match-all primes (list integer)-    [<join _ <cons $p <cons ,(+ p 2) _>>>-     [p (+ p 2)]]))+-- Extract all twin primes from the infinite list of prime numbers with pattern matching!+twinPrimes :=+  matchAll primes as list integer with+    | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2) -;; Enumerate first 10 twin primes.-(take 10 twin-primes)-;=>{[3 5] [5 7] [11 13] [17 19] [29 31] [41 43] [59 61] [71 73] [101 103] [107 109]}+-- Enumerate first 10 twin primes.+take 10 twinPrimes+-- => [(3, 5), (5, 7), (11, 13), (17, 19), (29, 31), (41, 43), (59, 61), (71, 73), (101, 103), (107, 109)]
− sample/efficient-backtracking.egi 
@@ -1,14 +0,0 @@-(match (between 1 n) (multiset integer)-  {[<cons $x <cons ,x _>> "Matched"]-   [_ "Not matched"]})-; Returns "Not matched" in O(n^2).--(match (between 1 n) (multiset integer)-  {[<cons $x <cons ,x <cons ,x _>>> "Matched"]-   [_ "Not matched"]})-; Returns "Not matched" in O(n^2).--(match (between 1 n) (multiset integer)-  {[<cons $x <cons ,x <cons ,x <cons ,x _>>>> "Matched"]-   [_ "Not matched"]})-; Returns "Not matched" in O(n^2).
− sample/five-color.egi 
@@ -1,42 +0,0 @@-;;;-;;; 5-color-;;;---(define $node [integer (maybe integer)])-(define $graph (set [node (multiset node)]))--(define $colors (between 1 5))--(define $graph-data-  {[[1 Nothing] {[2 Nothing]}]-   [[2 Nothing] {[1 Nothing]}]})--(define $main-  (lambda [$graph-data]-    (match [colors graph-data] [(set integer) graph]-      {; 周りのノードでまだ5色全部使われていない場合．-       [[<cons $c _> <cons [[$id (nothing)] !<cons [_ (just ,c)] _>] _>]-        (main (assign-color id c graph-data))]-       ; 次数が5で周りで5色全部使われているノードしか残っていない場合．-       [[_ <cons [[$id (nothing)] <cons [$nid_1 (just $c_1)] <cons [$nid_2 (just $c_2)] <cons [$nid_3 (just $c_3)] <cons [$nid_4 (just $c_4)] <cons [$nid_5 (just $c_5)] <nil>>>>>>] _>]-        undefined]-       ; すべてのノードに色付け完了．-       [_ graph-data]-       })))--(define $assign-color-  (lambda [$id $c $graph-data]-    (map (lambda [$n]-           [(rewrite-node id c (2#%1 n)) (map (lambda [$n] (rewrite-node id c n)) (2#%2 n))])-         graph-data)))--(define $rewrite-node-  (lambda [$id $c $n]-    (match n node-      {[[,id (nothing)] [id (Just c)]]-       [_ n]})))--(rewrite-node 1 5 [1 Nothing]) ; [1 {5}]-(assign-color 1 5 graph-data) ; {[[1 {5}] {[2 {}]}] [[2 {}] {[1 {5}]}]}-(main graph-data) ; {[[1 {1}] {[2 {2}]}] [[2 {2}] {[1 {1}]}]}
+ sample/generalized-sequential-pattern-mining.egi view
@@ -0,0 +1,137 @@+---+--- Yu Hirate, Hayato Yamana: Generalized Sequential Pattern Mining with Item Interval, Journal of Computer Vol. 1, No 3, June 2006+---++--+-- Configuration+--++items := [a, b, c, d, e, f]++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)++C1 := 0      -- min_interval+C2 := 172800 -- max_interval+C3 := 0      -- min_whole_interval+C4 := 300000 -- max_whole_interval++I t := floor (rtof (t / (60 * 60 * 24)))++--+-- Utils+--++query := list (integer, eq)++sequence := list (time, list eq)++time := matcher+  | interval $ $ as (integer, integer) with+    | $t -> [(I t, t)]+  | $ as something with+    | $tgt -> [tgt]+++--+-- Algorithm+--++-- calculate ISDB|α+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+  | [] -> ISDB+  | ($a, $x) :: $α' -> project' (map (\b y -> (b - a, y))  α')+                                (map (\xss -> matchAllDFS xss as set sequence with+                                              | (_ ++ (interval #a $t, _ ++ #x :: $cs) :: $ls) :: _+                                              -> (0, cs) :: (map (\t' xs -> (t' - t, xs)) ls))+                                     ISDB)+  +-- main function+gspm items ISDB I minSup C1 C2 C3 C4 :=+  let φ := [] in+  let R := [] in+  let fs := filter (\α ISDB' -> match ISDB' as multiset sequence with+                                | loop $i (1, minSup) (![] :: ...) _ -> True+                                | _ -> False)+                   (map (\α -> (α, project α ISDB)) (map (\x -> [(0, x)]) items)) in+  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 :=+  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+  -- TODO: apply C3+  iss' ++ concat (map (\α' -> projection α' (project α' ISDB) I minSup C1 C2 C3 C4)+                      iss')++freqItem ISDB minSup C1 C2 C3 C4 :=+  matchAll ISDB as list (list sequence) with+  | first (interval $a $t) $x+      (loop $i (2, minSup)+         (first (interval #a _) #x ...)+         !(first (interval #a _) #x _))+  -> (a, t, x)++first := \pt px ps =>+  {@ ++ (@ ++ (@ ++ ((interval $t _ & ~pt), _ ++ ($x & ~px) :: _) :: _) :: _) :: @,+   (!(_ ++ (_ ++ (_ ++ (interval #t _, _ ++ #x :: _) :: _) :: _) :: _),+    !(_ ++ (_ ++ (interval #t _, _ ++ #x :: _) :: _) :: _),+    !(_ ++ (interval #t _, _ ++ #x :: _) :: _),+    ~ps)}++--+-- Execute+--++--gspm items ISDB I minSup C1 C2 C3 C4+++--+-- Test+--+++assertEqual "project (level 1)"+  (project [(0, a)] ISDB)+  [[[(0, []), (86400, [a, b, c]), (259200, [a, c])], [(0, [b, c]), (172800, [a, c])], [(0, [c])]], [[(0, [d]), (259200, [c])]], [[(0, [e, f]), (172800, [a, b])], [(0, [b])]]]++assertEqual "project (level 2)"+  (project [(0, a),(0, b)] ISDB)+  [[[(0, [c]), (172800, [a, c])]], [], [[(0, [])]]]++assertEqual "project (level 2)"+  (project [(0, a),(2, a)] ISDB)+  [[[(0, [c])]], [], [[(0, [b])]]]++assertEqual "freqItem"+  (freqItem+     [[[(0, []), (86400, [a, b, c]), (259200, [a, c])], [(0, [b, c]), (172800, [a, c])], [(0, [c])]], [[(0, [d]), (259200, [c])]], [[(0, [e, f]), (172800, [a, b])], [(0, [b])]]]+     minSup C1 C2 C3 C4)+  [(0, 0, b), (3, 259200, c), (2, 172800, a)]++(filter (\a t x -> C1 <= t && t <= C2)+  (freqItem+     [[[(0, []), (86400, [a, b, c]), (259200, [a, c])], [(0, [b, c]), (172800, [a, c])], [(0, [c])]],+      [[(0, [d]), (259200, [c])]],+      [[(0, [b])]]]+     minSup C1 C2 C3 C4))+--[(0, 0, b)]++gspm items ISDB I minSup C1 C2 C3 C4+[[(0, a)],+ [(0, b)],+ [(0, c)],+ [(0, a), (0, b)],+ [(0, a), (2, a)]]
− sample/graph.egi 
@@ -1,85 +0,0 @@-;;;-;;;-;;; Graph demonstration-;;;-;;;--;;-;; Matcher definitions-;;-(define $graph-  (lambda [$a]-    (set (edge a))))--(define $edge-  (lambda [$a]-    (algebraic-data-matcher-      {<edge a a>})))--;;-;; Sample data-;;-(define $graph-data1-  {<Edge 1 4>-   <Edge 2 1>-   <Edge 3 1>-   <Edge 3 2>-   <Edge 4 3>-   <Edge 5 1>-   <Edge 5 4>-   })--(define $graph-data2-  {<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'-(test (let {[$s 1]}-        (match-all graph-data1 (graph integer)-          [<cons <edge ,s $x>-                 !<cons <edge ,x ,s>-                        _>>-           x])))--;; find all nodes in two paths from 's'-(test (let {[$s 1]}-        (match-all graph-data1 (graph integer)-          [<cons <edge (& ,s $x_1) $x_2>-                 <cons <edge ,x_2 $x_3>-                       _>>-           x])))--;; enumerate first 5 paths from 's' to 'e'-(test (take 5 (let {[$s 1] [$e 2]}-                 (match-all graph-data2 (graph integer)-                   [<cons <edge (& ,s $x_1) $x_2>-                          (loop $i [4 $n]-                            <cons <edge ,x_(- i 2) $x_(- i 1)> ...>-                            <cons <edge ,x_(- n 1) (& ,e $x_n)> _>)>-                    x]))))--;; find all cliques whose size is 'n'-(test (let {[$n 3]}-        (match-all graph-data2 (graph integer)-          [<cons <edge $x_1 $x_2>-                 (loop $i [3 n]-                   <cons <edge ,x_1 $x_i>-                         (loop $j [2 (- i 1)]-                           <cons <edge ,x_j ,x_i> ...>-                           ...)>-                   _)>-           x])))
− sample/io/args.egi 
@@ -1,15 +0,0 @@-(define $write-each-  (lambda [$xs]-    (match xs (list something)-      {[<nil> (do {} (return []))]-       [<cons $x $rs>-        (do {[(write x)]-             [(write "\n")]}-          (write-each rs))]})))--(define $main-  (lambda [$args]-    (do {[(write "args: ")]-         [(write (show args))]-         [(write "\n")]}-      (write-each args))))
− sample/io/cat.egi 
@@ -1,5 +0,0 @@-(define $main-  (lambda [$args]-    (match args (list string)-      {[<nil> (each-line print)]-       [_ (each-file args print)]})))
− sample/io/cut.egi 
@@ -1,11 +0,0 @@-(define $main-  (lambda [$args]-    (match args (list string)-      {[<cons $file $nums> (cut file (map read nums))]})))--(define $cut-  (lambda [$file $nums]-    (do {[$port (open-input-file file)]-         (each-line-from-port port (lambda [$line] (let {[$fs (S.split "," line)]}-                                                     (print (S.intercalate "," (map (nth $ fs) nums))))))-         (close-input-port port)})))
− sample/io/dice.egi 
@@ -1,5 +0,0 @@-(define $main-  (lambda [$argv]-    (do {[$v (rand 1 6)]-         (write (show v))-         (write-char '\n')})))
− sample/io/hello.egi 
@@ -1,3 +0,0 @@-(define $main-  (lambda [$args]-    (print "Hello, world!")))
− sample/io/print-primes.egi 
@@ -1,4 +0,0 @@-(define $main-  (lambda [$argv]-    (each print (map show primes))))-
sample/mahjong.egi view
@@ -1,77 +1,78 @@-;;;-;;;-;;; Mah-jong example-;;;-;;;+--+--+-- Mah-jong example+--+-- -;;-;; Matcher definitions-;;-(define $suit-  (algebraic-data-matcher-    {<wan> <pin> <sou>}))+--+-- Matcher definitions+--+suit :=+  algebraicDataMatcher+    | wan+    | pin+    | sou -(define $honor-  (algebraic-data-matcher-    {<ton> <nan> <sha> <pe> <haku> <hatsu> <chun>}))+honor :=+  algebraicDataMatcher+    | ton+    | nan+    | sha+    | pe+    | haku+    | hatsu+    | chun -(define $tile-  (algebraic-data-matcher-    {<num suit integer> <hnr honor>}))+tile :=+  algebraicDataMatcher+    | num suit integer+    | hnr honor -;;-;; Pattern modularization-;;-(define $twin-  (pattern-function [$pat1 $pat2]-    <cons (& $pat pat1)-     <cons ,pat-      pat2>>))+--+-- Pattern modularization+--+twin := \pat1 pat2 => ($pat & ~pat1) :: #pat :: ~pat2 -(define $shuntsu-  (pattern-function [$pat1 $pat2]-    <cons (& <num $s $n> pat1)-     <cons <num ,s ,(+ n 1)>-      <cons <num ,s ,(+ n 2)>-       pat2>>>))+shuntsu :=+  \pat1 pat2 =>+    (num $s $n & ~pat1) :: num #s #(n + 1) :: num #s #(n + 2) :: ~pat2 -(define $kohtsu-  (pattern-function [$pat1 $pat2]-    <cons (& $pat pat1)-     <cons ,pat-      <cons ,pat-       pat2>>>))+kohtsu := \pat1 pat2 => ($pat & ~pat1) :: #pat :: #pat :: ~pat2 -;;-;; A function that determines whether the hand is completed or not.-;;-(define $complete?-  (match-lambda (multiset tile)-    {[(twin $th_1-       (| (shuntsu $sh_1 (| (shuntsu $sh_2 (| (shuntsu $sh_3 (| (shuntsu $sh_4 <nil>)-                                                                (kohtsu $kh_1 <nil>)))-                                              (kohtsu $kh_1 (kohtsu $kh_2 <nil>))))-                            (kohtsu $kh_1 (kohtsu $kh_2 (kohtsu $kh_3 <nil>)))))-          (kohtsu $kh_1 (kohtsu $kh_2 (kohtsu $kh_3 (kohtsu $kh_4 <nil>)))))-       (twin $th_2 (twin $th_3 (twin $th_4 (twin $th_5 (twin $th_6 (twin $th_7 <nil>)))))))-      #t]-     [_ #f]}))+--+-- A function that determines whether the hand is completed or not.+--+complete? :=+  \match as multiset tile with+    | twin+        $th_1+        (shuntsu $sh_1+           (shuntsu $sh_2+              (shuntsu $sh_3 (shuntsu $sh_4 [] | kohtsu $kh_1 [])+              | kohtsu $kh_1 (kohtsu $kh_2 []))+           | kohtsu $kh_1 (kohtsu $kh_2 (kohtsu $kh_3 [])))+        | kohtsu $kh_1 (kohtsu $kh_2 (kohtsu $kh_3 (kohtsu $kh_4 []))))+        (twin $th_2 (twin $th_3 (twin $th_4 (twin $th_5 (twin $th_6 (twin $th_7 []))))))+    -> True+    | _ -> False -;;-;; Demonstration code-;;-(assert-equal "mahjong 1"-  (complete? {<Hnr <Haku>> <Hnr <Haku>>-              <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>-              <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>-              <Num <Pin> 2> <Num <Pin> 3> <Num <Pin> 4>-              <Num <Sou> 6> <Num <Sou> 6> <Num <Sou> 6>})-  #t)+--+-- Demonstration code+--+assertEqual "mahjong 1"+  (complete?+     [ Hnr Haku,  Hnr Haku+     , Num Wan 3, Num Wan 4, Num Wan 5+     , Num Wan 6, Num Wan 7, Num Wan 8+     , Num Pin 2, Num Pin 3, Num Pin 4+     , Num Sou 6, Num Sou 6, Num Sou 6 ])+  True -(assert-equal "mahjong 2"-  (complete? {<Hnr <Haku>> <Hnr <Haku>>-              <Num <Pin> 1> <Num <Pin> 3> <Num <Pin> 4>-              <Num <Wan> 6> <Num <Wan> 7> <Num <Wan> 8>-              <Num <Wan> 3> <Num <Wan> 4> <Num <Wan> 5>-              <Num <Sou> 6> <Num <Sou> 6> <Num <Sou> 6>})-  #f)+assertEqual "mahjong 2"+  (complete?+     [ Hnr Haku,  Hnr Haku+     , Num Pin 1, Num Pin 3, Num Pin 4+     , Num Wan 6, Num Wan 7, Num Wan 8+     , Num Wan 3, Num Wan 4, Num Wan 5+     , Num Sou 6, Num Sou 6, Num Sou 6 ])+  False
− sample/math/algebra/cubic-equation.egi 
@@ -1,45 +0,0 @@-(define $cubic-formula c-f)--(define $c-f-  (lambda [$f $x]-    (match (coefficients f x) (list math-expr)-      {[<cons $a_0 <cons $a_1 <cons $a_2 <cons $a_3 <nil>>>>>-        (c-f' a_3 a_2 a_1 a_0)]})))--(define $c-f'-  (lambda [$a $b $c $d]-    (match [a b c d] [math-expr math-expr math-expr math-expr]-      {[[,1 ,0 $p $q]-        (let {[[$s1 $s2] (2#[(rt 3 %1) (rt 3 %2)] (q-f' 1 (* 27 q) (* -27 p^3)))]}-          [(/ (+ s1 s2) 3)               ; r1-           (/ (+ (* w^2 s1) (* w s2)) 3) ; r2-           (/ (+ (* w s1) (* w^2 s2)) 3) ; r3-           ])]-       [[,1 _ _ _]-        (3#[(- %1 (/ b 3)) (- %2 (/ b 3)) (- %3 (/ b 3))]-           (with-symbols {x y}-             (c-f (substitute {[x (- y (/ b 3))]} (+ x^3 (* b x^2) (* c x) d)) y)))]-       [[_ _ _ _] (c-f' 1 (/ b a) (/ c a) (/ d a))]})))--(define $w (/ (+ -1 (* i (sqrt 3))) 2))--(* (- x 1) (- x 2) (- x 3))-;=>(+ x^3 (* -6 x^2) (* 11 x) -6)--(c-f (+ x^3 (* -6 x^2) (* 11 x) -6) x)-;=>[2 1 3]--(3#%1 (c-f (+ x^3 (* p x) q) x))-;=>-;(/ (+ (rt 3 (+ (* -108 q)-;               (* 12 (sqrt (+ (* 81 q^2) (* 12 p^3))))))-;      (rt 3 (+ (* -108 q)-;               (* -12 (sqrt (+ (* 81 q^2) (* 12 p^3)))))))-;   6)--(3#%1 (c-f (+ (* a x^3) (* b x^2) (* c x) d) x))-;=>-;(/ (+ (* (rt 3 (/ (+ (* -108 d a^3) (* 36 c b a^2) (* -8 b^3 a) (* 12 (sqrt (+ (* 81 a^6 d^2) (* -54 a^5 d c b) (* 12 a^4 d b^3) (* -3 a^4 c^2 b^2) (* 12 a^5 c^3))))) a^4)) a)-;      (* (rt 3 (/ (+ (* -108 d a^3) (* 36 c b a^2) (* -8 b^3 a) (* -12 (sqrt (+ (* 81 a^6 d^2) (* -54 a^5 d c b) (* 12 a^4 d b^3) (* -3 a^4 c^2 b^2) (* 12 a^5 c^3))))) a^4)) a)-;      (* -2 b))-;    (* 6 a))
− sample/math/algebra/quadratic-equation.egi 
@@ -1,36 +0,0 @@-(define $quadratic-formula q-f)--(define $q-f-  (lambda [$f $x]-    (match (coefficients f x) (list math-expr)-      {[<cons $a_0 <cons $a_1 <cons $a_2 <nil>>>>-        (q-f' a_2 a_1 a_0)]})))--(define $q-f'-  (lambda [$a $b $c]-    (match [a b c] [math-expr math-expr math-expr]-      {[[,1 ,0 _]-        [(sqrt (* -1 c)) (* -1 (sqrt (* -1 c)))]]-       [[,1 _ _]-        (2#[(+ (* -1 (/ b 2)) %1) (+ (* -1 (/ b 2)) %2)]-           (with-symbols {x y}-             (q-f (substitute {[x (- y (/ b 2))]} (+ x^2 (* b x) c)) y)))]-       [[_ _ _] (q-f' 1 (/ b a) (/ c a))]})))---(q-f (+ x^2 x 1) x)-;=>-;[(/ (+ -1 (* i (sqrt 3))) 2)-; (/ (+ -1 (* -1 i (sqrt 3))) 2)]--(q-f (+ (* a x^2) (* b x) c) x)-;=>-;[(/ (+ (* -1 b) (sqrt (+ b^2 (* -4 c a))))-;    (* 2 a))-; (/ (+ (* -1 b) (* -1 (sqrt (+ b^2 (* -4 c a)))))-;    (* 2 a))]--(q-f (+ (* a x^2) (* 2 b x) c) x)-;=>-;[(/ (+ (* -1 b) (sqrt (+ b^2 (* -1 c a)))) a)-; (/ (+ (* -1 b) (* -1 (sqrt (+ b^2 (* -1 c a))))) a)]
− sample/math/algebra/quartic-equation.egi 
@@ -1,34 +0,0 @@-(define $quartic-formula qt-f)--(define $qt-f-  (lambda [$f $x]-    (match (coefficients f x) (list math-expr)-      {[<cons $a_0 <cons $a_1 <cons $a_2 <cons $a_3 <cons $a_4 <nil>>>>>>-        (qt-f' a_4 a_3 a_2 a_1 a_0)]})))--(define $qt-f'-  (lambda [$a $b $c $d $e]-    (match [a b c d e] [math-expr math-expr math-expr math-expr math-expr]-      {[[,1 ,0 $p ,0 $q]-        (let* {[[$s1 $s2] (q-f' 1 p q)]-               [[$r1 $r2] (q-f' 1 0 (* -1 s1))]-               [[$r3 $r4] (q-f' 1 0 (* -1 s2))]}-          [r1 r2 r3 r4])]-       [[,1 ,0 $p $q $r]-        (let* {[$u (3#%1 (with-symbols {u} (c-f (+ (* u (+ p u)^2) (* -4 r u) (* -1 q^2)) u)))]-               [[$r1 $r2] (q-f (+ y^2 (/ (+ p u) 2) (* (sqrt u) (- y (/ q (* 2 u))))) y)]-               [[$r3 $r4] (q-f (+ y^2 (/ (+ p u) 2) (* -1 (sqrt u) (- y (/ q (* 2 u))))) y)]}-          [r1 r2 r3 r4])]-       [[,1 _ _ _ _]-        (4#[(- %1 (/ b 4)) (- %2 (/ b 4)) (- %3 (/ b 4)) (- %4 (/ b 4))]-           (with-symbols {x y}-             (qt-f (substitute {[x (- y (/ b 4))]} (+ x^4 (* b x^3) (* c x^2) (* d x) e)) y)))]-       [[_ _ _ _ _] (qt-f' 1 (/ b a) (/ c a) (/ d a) (/ e a))]})))--(define $w (/ (+ -1 (* i (sqrt 3))) 2))--(* (- x 1) (- x 2) (- x 3) (- x 4))-;=>(+ x^4 (* -10 x^3) (* 35 x^2) (* -50 x) 24)--(qt-f (+ x^4 (* -10 x^3) (* 35 x^2) (* -50 x) 24) x)-;=>[4 1 3 2]
− sample/math/algebra/quartic-formula.egi 
@@ -1,28 +0,0 @@-(define $quartic-formula qt-f)--(define $qt-f-  (lambda [$f $x]-    (match (coefficients f x) (list math-expr)-      {[<cons $a_0 <cons $a_1 <cons $a_2 <cons $a_3 <cons $a_4 <nil>>>>>>-        (qt-f' a_4 a_3 a_2 a_1 a_0)]})))--(define $qt-f'-  (lambda [$a $b $c $d $e]-    (match [a b c d e] [math-expr math-expr math-expr math-expr math-expr]-      {[[,1 ,0 $p ,0 $q]-        (let* {[[$s1 $s2] (q-f' 1 p q)]-               [[$r1 $r2] (q-f' 1 0 (* -1 s1))]-               [[$r3 $r4] (q-f' 1 0 (* -1 s2))]}-          [r1 r2 r3 r4])]-       [[,1 ,0 $p $q $r]-        (let* {[$u '(3#%1 (with-symbols {u} (c-f (+ (* u (+ p u)^2) (* -4 r u) (* -1 q^2)) u)))]-               [[$r1 $r2] (q-f (+ y^2 (/ (+ p u) 2) (* (sqrt u) (- y (/ q (* 2 u))))) y)]-               [[$r3 $r4] (q-f (+ y^2 (/ (+ p u) 2) (* -1 (sqrt u) (- y (/ q (* 2 u))))) y)]}-          [r1 r2 r3 r4])]-       [[,1 _ _ _ _]-        (4#[(- %1 (/ b 4)) (- %2 (/ b 4)) (- %3 (/ b 4)) (- %4 (/ b 4))]-           (with-symbols {x y}-             (qt-f (substitute {[x (- y (/ b 4))]} (+ x^4 (* b x^3) (* c x^2) (* d x) e)) y)))]-       [[_ _ _ _ _] (qt-f' 1 (/ b a) (/ c a) (/ d a) (/ e a))]})))--;(define $w (/ (+ -1 (* i (sqrt 3))) 2))
− sample/math/analysis/complex-analysis.egi 
@@ -1,47 +0,0 @@-;;;;;-;;;;; Complex Integration-;;;;;--(define $C1 (dSd x 0 a x))-(define $C2 (dSd y 0 b (* i (- a (* i y)))))--(define $C2' (dSd y 0 b (* i (* -1 (* i y)))))-(define $C1' (dSd x 0 a (- x (* i b))))--C1 ;=>(/ a^2 2)-C2 ;=>(/ (+ (* 2 i a b) b^2) 2)--C2';=>(/ b^2 2)-C1';=>(/ (+ a^2 (* -2 i b a)) 2)--(+ C1 C2);=>(/ (+ a^2 (* 2 i a b) b^2) 2)-(+ C2' C1');=>(/ (+ b^2 a^2 (* -2 i b a)) 2)--(- (+ C1 C2)-   (+ C2' C1'))-;=>(* 2 i a b)---(define $D1 (dSd x 0 a x))-(define $D2 (dSd y 0 b (* i (+ a (* i y)))))--(define $D2' (dSd y 0 b (* i (* i y))))-(define $D1' (dSd x 0 a (+ x (* i b))))--D1 ;=>(/ a^2 2)-D2 ;=>(/ (+ (* 2 i a b) (* -1 b^2)) 2)--D2';=>(/ (* -1 b^2) 2)-D1';=>(/ (+ a^2 (* 2 i b a)) 2)--(- (+ D1 D2)-   (+ D2' D1'))-;=>0--(define $E (dSd t 0 (* 2 pi) (* r (** e (* -1 i t)) i r (** e (* i t)))))--E;=>(* 2 i r^2 pi)--(define $F (dSd t 0 (* 2 pi) (exp (* i t))))--F;=>0
− sample/math/analysis/eulers-formula.egi 
@@ -1,11 +0,0 @@-(take 8 (taylor-expansion (** e (* i x)) x 0))-;{1 (* i x) (/ (* -1 x^2) 2) (/ (* -1 i x^3) 6) (/ x^4 24) (/ (* i x^5) 120) (/ (* -1 x^6) 720) (/ (* -1 i x^7) 5040)}--(take 8 (taylor-expansion (cos x) x 0))-;{1 0 (/ (* -1 x^2) 2) 0 (/ x^4 24) 0 (/ (* -1 x^6) 720) 0}--(take 8 (taylor-expansion (* i (sin x)) x 0))-;{0 (* i x) 0 (/ (* -1 i x^3) 6) 0 (/ (* i x^5) 120) 0 (/ (* -1 i x^7) 5040)}--(take 8 (map2 + (taylor-expansion (cos x) x 0) (taylor-expansion (* i (sin x)) x 0)))-;{1 (* i x) (/ (* -1 x^2) 2) (/ (* -1 i x^3) 6) (/ x^4 24) (/ (* i x^5) 120) (/ (* -1 x^6) 720) (/ (* -1 i x^7) 5040)}
− sample/math/analysis/laplacian-hessian-jacobian.egi 
@@ -1,33 +0,0 @@-(define $parameters [| x y z |]) --(define $∂ (∂/∂ $ parameters))--(∂_i [| x^2 y^2 z^2 |]_i)-;[| (* 2 x) (* 2 y) (* 2 z) |]_i--(∂_i [| x^2 y^2 z^2 |]_j)-;[| [| (* 2 x) 0 0 |] [| 0 (* 2 y) 0 |] [| 0 0 (* 2 z) |] |]_i_j--(define $Δ-  (lambda [%f]-    (with-symbols {i}-      (contract + (∂~i (∂_i f))))))--(define $Hessian-  (lambda [%f]-    (with-symbols {i j}-      (∂_i (∂_j f)))))--(define $Jacobian-  (lambda [%v]-    (with-symbols {i j}-      (M.det (∂_i v_j)))))--(Δ (+ x^2 y^2 z^2))-;6--(Hessian (+ x^2 y^2 z^2))-;[| [| 2 0 0 |] [| 0 2 0 |] [| 0 0 2 |] |]--(Jacobian [| x^2 y^2 z^2 |])-;(* 8 x y z)
− sample/math/analysis/leibniz-formula.egi 
@@ -1,41 +0,0 @@-(define $f (lambda [$x] x))--(define $multSd-  (lambda [$x $f $G]-    (let {[$F (Sd x f)]}-      (- (* F G)-         (Sd x (* f (d/d G x)))))))--(multSd x (cos x) (f x));(+ (* (sin x) x) (* -1 (sin x)))-(multSd x (cos (* 2 x)) (f x));(/ (+ (* 2 (sin (* 2 x)) x) (* -2 (sin (* 2 x)))) 4)-(multSd x (cos (* n x)) (f x));(/ (+ (* (sin (* n x)) x n) (* -1 (sin (* n x)) n)) n^2)--(multSd x (sin x) (f x));(+ (* -1 (cos x) x) (cos x))-(multSd x (sin (* 2 x)) (f x));(/ (+ (* -1 (cos (* 2 x)) x) (cos (* 2 x))) 2)-(multSd x (sin (* n x)) (f x));(/ (+ (* -1 (cos (* n x)) x) (cos (* n x))) n)---(define $as (map (lambda [$n] (let {[$F (multSd x (cos (* n x)) (f x))]}-                                (/ (- (substitute {[x π]} F) (substitute {[x (* -1 π)]} F))-                                   π)))-                 nats))-(take 10 as)-;{0 0 0 0 0 0 0 0 0 0}--(define $bs (map (lambda [$n] (let {[$F (multSd x (sin (* n x)) (f x))]}-                                (/ (- (substitute {[x π]} F) (substitute {[x (* -1 π)]} F))-                                   π)))-                 (take 10 nats)))-(take 10 bs)-;{2 -1 (/ 2 3) (/ -1 2) (/ 2 5) (/ -1 3) (/ 2 7) (/ -1 4) (/ 2 9) (/ -1 5)}--(define $f' (map (lambda [$k $b] (* b (sin (* k x)))) (zip nats bs)))--(take 10 f')-;{(* 2 (sin x)) (* -1 (sin (* 2 x))) (/ (* 2 (sin (* 3 x))) 3) (/ (* -1 (sin (* 4 x))) 2) (/ (* 2 (sin (* 5 x))) 5) (/ (* -1 (sin (* 6 x))) 3) (/ (* 2 (sin (* 7 x))) 7) (/ (* -1 (sin (* 8 x))) 4) (/ (* 2 (sin (* 9 x))) 9) (/ (* -1 (sin (* 10 x))) 5)}--(take 10 (map (substitute {[x (/ π 2)]} $) f'))-;{2 0 (/ -2 3) 0 (/ 2 5) 0 (/ -2 7) 0 (/ 2 9) 0} ; = (/ pi 2)--(map (/ $ 2) (take 10 (map (substitute {[x (/ π 2)]} $) f')))-;{1 0 (/ -1 3) 0 (/ 1 5) 0 (/ -1 7) 0 (/ 1 9) 0} ; = (/ pi 4)
− sample/math/analysis/order-of-partial-derivative.egi 
@@ -1,13 +0,0 @@-(define $f-  (lambda [$x $y $z]-    (/ (* x^5 y^3) z)))--(f x y z);(/ (* x^5 y^3) z)--(∂/∂x (f x y z));(/ (* 5 x^4 y^3) z)-(∂/∂y (∂/∂x (f x y z)));(/ (* 15 x^4 y^2) z)-(∂/∂z (∂/∂y (∂/∂x (f x y z))));(/ (* 15 x^4 y^2) z)--(∂/∂x (∂/∂y (∂/∂z (f x y z))));(/ (* 15 x^4 y^2) z)-(∂/∂y (∂/∂z (∂/∂x (f x y z))));(/ (* 15 x^4 y^2) z)-(∂/∂z (∂/∂y (∂/∂x (f x y z))));(/ (* 15 x^4 y^2) z)
− sample/math/analysis/vector-analysis.egi 
@@ -1,112 +0,0 @@-;;-;; Tensor Arithmetics-;;-(+ 1 [| 1 2 3 |])-;=>[|2 3 4|]--(+ [| 1 2 3 |] 1)-;=>[|2 3 4|]--(+ [| 1 2 3 |]_i [| 1 2 3 |]_i)-;=>[|2 4 6|]_i--(+ [| 10 20 30 |] [| 1 2 3 |])-;=>[| [| 11 12 13 |] [| 21 22 23 |] [| 31 32 33 |] |]--(+ [| 100 200 300 |]_i-   [|[| 1 2 3 |]-     [| 10 20 30 |]|]_j_i)-;=>[| [| 101 110 |] [| 202 220 |] [| 303 330 |] |]_i_j--(+ [|[| 11 12 |]-     [| 21 22 |]-     [| 31 32 |]|]_i_j-   [| 100 200 300 |]_i)-;=>[| [| 111 112 |] [| 221 222 |] [| 331 332 |] |]_i_j--(+ [| 100 200 300 |]_i-   [|[| 11 12 |]-     [| 21 22 |]-     [| 31 32 |]|]_i_j)-;=>[| [| 111 112 |] [| 221 222 |] [| 331 332 |] |]_i_j--;;-;; Derivative-;;-(∂/∂ (f x y z) x)-;=>(f_1 x y z)--(∂/∂ [| (f x) (g x) |] x)-;=>[| (f_1 x) (g_1 x) |]--(∂/∂ (f x y z) [| x y z |])-;=>[| (f_1 x y z) (f_2 x y z) (f_3 x y z) |]--([| (∂/∂ $ x) (∂/∂ $ y) |] (f x y))-;=>[| (f_1 x y) (f_2 x y) |]--([| (∂/∂ $ x) (∂/∂ $ y) |] [| (f x y) (g x y) |])-;=>[| [| (f_1 x y) (g_1 x y) |] [| (f_2 x y) (g_2 x y) |] |]--;;-;; Nabla-;;-(define $∇ ∂/∂)--(∇ (f x y) [| x y |])-;=>[| (f_1 x y) (f_2 x y) |]--(∇ [| (f x y) (g x y) |] [| x y |])-;=>[| [| (f_1 x y) (f_2 x y) |] [| (g_1 x y) (g_2 x y) |] |]--;;-;; Contraction-;;-(contract + (* [|1 2 3|]~i [|10 20 30|]_i))-;=>-140--(define $trace (lambda [%t] (with-symbols {i} (contract + t~i_i))))--(trace [|[|10 20 30|] [|20 40 60|] [|30 60 90|]|])-;=>-140--;;-;; Divergence-;;-(define $div (compose ∇ (trace $)))--(div [| (f x y z) (g x y z) (h x y z) |] [| x y z |])-;=>(+ (f_1 x y z) (g_2 x y z) (h_3 x y z))--;;-;; Taylor Expansion-;;-(define $taylor-expansion-  (lambda [%f %xs %as]-    (with-symbols {h}-      (let {[$hs (generate-tensor 1#h_%1 (tensor-shape xs))]}-        (map2 *-              (map 1#(/ 1 (fact %1)) nats0)-              (map (compose (V.substitute xs as $)-                            (V.substitute hs (with-symbols {i} (- xs_i as_i)) $))-                   (iterate (compose (∇ $ xs) (V.* hs $)) f)))))))--(take 3 (taylor-expansion (f x) x 0))-;=>-;{(f 0)-; (* x (f_1 0))-; (/ (* x^2 (f_1_1 0))-;    2)}--(take 3 (taylor-expansion (f x y) [| x y |] [| 0 0 |]))-;=>-;{(f 0 0)-; (+ (* x (f_1 0 0))-;    (* y (f_2 0 0)))-; (/ (+ (* x^2 (f_1_1 0 0))-;       (* x y (f_2_1 0 0))-;       (* y x (f_1_2 0 0))-;       (* y^2 (f_2_2 0 0)))-;    2)}
− sample/math/geometry/chern-form-of-CP1.egi 
@@ -1,22 +0,0 @@-(define $params [| r θ |])--(define $u (* r (** e (* 2 π i θ))))-(define $ū (* r (** e (* -2 π i θ))))--(define $d-  (lambda [%X]-    !((flip ∂/∂) params X)))--(define $ω (/ (* ū (d u))-              (+ 1 (* u ū))))-ω;[| (/ r (+ 1 r^2)) (/ (* 2 r^2 π i) (+ 1 r^2)) |]--(define $Ω (df-normalize (d ω)))-Ω;[| [| 0 (/ (* 2 r π i) (+ 1 (* 2 r^2) r^4)) |] [| (/ (* -2 r π i) (+ 1 (* 2 r^2) r^4)) 0 |] |]--(define $c1 (/ Ω (* -2 π i)))-c1;[| [| 0 (/ r (+ -1 (* -2 r^2) (* -1 r^4))) |] [| (/ (* -1 r) (+ -1 (* -2 r^2) (* -1 r^4))) 0 |] |]--; ∫ dθ dr (/ (* -2 r) (+ 1 (* 2 r^2) r^4)) = ∫ dθ dr (/ (* -2 r) (+ 1 r^2)^2)-; = ∫ dr (/ (* -2 r) (+ 1 r^2)^2) = [ (/ 1 (+ 1 r^2)) ] 0-∞ = (- 0 1)-; = -1
− sample/math/geometry/chern-form-of-CP2.egi 
@@ -1,33 +0,0 @@-(define $params [| z1 z2 z1' z2' |])-(define $params' [| z1 z2 # # |])-(define $params'' [| # # z1' z2' |])--(define $d-  (lambda [%X]-    !((flip ∂/∂) params X)))--(define $d'-  (lambda [%X]-    !((flip ∂/∂) params' X)))--(define $d''-  (lambda [%X]-    !((flip ∂/∂) params'' X)))--(define $h (+ 1 (* z1 z1') (* z2 z2')))--(define $ω (d' (log h)))-ω;[| (/ z1' (+ 1 (* z1 z1') (* z2 z2'))) (/ z2' (+ 1 (* z1 z1') (* z2 z2'))) 0 0 |]--(define $Ω (d'' ω))-Ω-;[|[| 0 0 0 0 |]-;  [| 0 0 0 0 |]-;  [| (/ (+ 1 (* z2 z2')) (+ 1 (* 2 z1 z1') (* 2 z2 z2') (* z1^2 z1'^2) (* 2 z1 z1' z2 z2') (* z2^2 z2'^2))) (/ (* -1 z1 z2') (+ 1 (* 2 z1 z1') (* 2 z2 z2') (* z1^2 z1'^2) (* 2 z1 z1' z2 z2') (* z2^2 z2'^2))) 0 0 |]-;  [| (/ (* -1 z2 z1') (+ 1 (* 2 z1 z1') (* 2 z2 z2') (* z1^2 z1'^2) (* 2 z1 z1' z2 z2') (* z2^2 z2'^2))) (/ (+ 1 (* z1 z1')) (+ 1 (* 2 z1 z1') (* 2 z2 z2') (* z1^2 z1'^2) (* 2 z1 z1' z2 z2') (* z2^2 z2'^2))) 0 0 |]|]--;(define $c1 (/ Ω (* -2 π i)))-;c1;[| [| 0 (/ r (+ -1 (* -2 r^2) (* -1 r^4))) |] [| (/ (* -1 r) (+ -1 (* -2 r^2) (* -1 r^4))) 0 |] |]---
− sample/math/geometry/covariant-exterior-derivative.egi 
@@ -1,59 +0,0 @@-;;; Parameters and Metric tensor--(define $x [| θ φ |])--(define $g__ [| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |])-(define $g~~ [| [| (/ 1 r^2) 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) |] |])--;;; Christoffel symbols--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x_k)-        (∂/∂ g_j_k x_l)-        (* -1 (∂/∂ g_k_l x_j)))))--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--;;; Riemann curvature tensor--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x_k) (∂/∂ Γ~i_j_k x_l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_1_1;[| [| 0 0 |] [| 0 0 |] |]~#_#-R~#_#_1_2;[| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_#-R~#_#_2_1;[| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_#-R~#_#_2_2;[| [| 0 0 |] [| 0 0 |] |]~#_#--;;; Connection form--(define $ω Γ~#_#_#)--;;; Curvature form--(define $wedge-  (lambda [%X %Y]-    !(. X Y)))--(define $d-  (lambda [%A]-    !((flip ∂/∂) x A)))--(define $D-  (lambda [%A]-    (with-symbols {i j}-      (+ (d A) (wedge ω~i_j A)))))--(define $Ω-  (with-symbols {i j}-    (df-normalize (+ (d ω~i_j)-                     (wedge ω~i_k ω~k_j)))))--Ω~#_#_1_1;[| [| 0 0 |] [| 0 0 |] |]~#_#-Ω~#_#_1_2;[| [| 0 (/ (sin θ)^2 2) |] [| (/ -1 2) 0 |] |]~#_#-Ω~#_#_2_1;[| [| 0 (/ (* -1 (sin θ)^2) 2) |] [| (/ 1 2) 0 |] |]~#_#-Ω~#_#_2_2;[| [| 0 0 |] [| 0 0 |] |]~#_#--
sample/math/geometry/curvature-form.egi view
@@ -1,54 +1,39 @@-;;; Parameters and Metric tensor--(define $x [| θ φ |])--(define $g__ [| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |])-(define $g~~ [| [| (/ 1 r^2) 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) |] |])--;;; Christoffel symbols--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--;;; Riemann curvature tensor+-- Parameters and metric tensor+x := [| θ, φ |] -(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))+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 -(assert-equal "Riemann curvature" R~#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]~#_#)-(assert-equal "Riemann curvature" R~#_#_1_2 [| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_#)-(assert-equal "Riemann curvature" R~#_#_2_1 [| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_#)-(assert-equal "Riemann curvature" R~#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]~#_#)+-- Christoffel symbols+Γ_j_l_k := (1 / 2) * (∂/∂ g_j_l x~k + ∂/∂ g_j_k x~l - ∂/∂ g_k_l x~j) -;;; Connection form+Γ~i_k_l := withSymbols [j] g~i~j . Γ_j_l_k -(define $ω Γ~#_#_#)+-- Riemann curvature+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 -;;; Curvature form+assertEqual "Riemann curvature" R~#_#_1_1 [| [| 0, 0 |], [| 0, 0 |] |]~#_#+assertEqual "Riemann curvature" R~#_#_1_2 [| [| 0, (sin θ)^2 |], [| -1, 0 |] |]~#_#+assertEqual "Riemann curvature" R~#_#_2_1 [| [| 0, -1 * (sin θ)^2 |], [| 1, 0 |] |]~#_#+assertEqual "Riemann curvature" R~#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]~#_# -(define $d-  (lambda [%A]-    !((flip ∂/∂) x A)))+-- Exterior derivative+d %t := !(flip ∂/∂) x t -(define $wedge-  (lambda [%X %Y]-    !(. X Y)))+-- Wedge product+infixl expression 7 ∧ -(define $Ω-  (with-symbols {i j}-    (df-normalize (+ (d ω~i_j)-                     (wedge ω~i_k ω~k_j)))))+(∧) %x %y := x !. y -(assert-equal "Curvature form" Ω~#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]~#_#)-(assert-equal "Curvature form" Ω~#_#_1_2 [| [| 0 (/ (sin θ)^2 2) |] [| (/ -1 2) 0 |] |]~#_#)-(assert-equal "Curvature form" Ω~#_#_2_1 [| [| 0 (/ (* -1 (sin θ)^2) 2) |] [| (/ 1 2) 0 |] |]~#_#)-(assert-equal "Curvature form" Ω~#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]~#_#)+-- Connection form+ω~i_j := Γ~i_j_# +-- Curvature form+Ω~i_j := withSymbols [k]+  antisymmetrize (d ω~i_j + ω~i_k ∧ ω~k_j) +assertEqual "Curvature form" Ω~#_#_1_1 [| [| 0, 0 |], [| 0, 0 |] |]~#_#+assertEqual "Curvature form" Ω~#_#_1_2 [| [| 0, (sin θ)^2  / 2|], [| -1 / 2, 0 |] |]~#_#+assertEqual "Curvature form" Ω~#_#_2_1 [| [| 0, -1 * (sin θ)^2 / 2 |], [| 1 / 2, 0 |] |]~#_#+assertEqual "Curvature form" Ω~#_#_2_2 [| [| 0, 0 |], [| 0, 0 |] |]~#_#
− sample/math/geometry/curvature.egi 
@@ -1,45 +0,0 @@-(define $d/dt (d/d $ t))--(define $ds/dt (sqrt (+ (d/dt (x t))^2 (d/dt (y t))^2)))--ds/dt;(sqrt (+ (x' t)^2 (y' t)^2))--(define $dt/ds (/ 1 ds/dt))--dt/ds;(/ 1 (sqrt (+ (x' t)^2 (y' t)^2)))--(define $e1 [(* (d/dt (x t)) dt/ds)-             (* (d/dt (y t)) dt/ds)])--e1-;[(/ (x' t)-;    (sqrt (+ (x' t)^2 (y' t)^2)))-; (/ (y' t)-;    (sqrt (+ (x' t)^2 (y' t)^2)))]--(define $e2 [(* -1 (d/dt (y t)) dt/ds)-             (* (d/dt (x t)) dt/ds)])--e2-;[(/ (* -1 (y' t))-;    (sqrt (+ (x' t)^2 (y' t)^2)))-; (/ (x' t)-;    (sqrt (+ (x' t)^2 (y' t)^2)))]--(define $de1/ds [(* (d/dt (fst e1)) dt/ds)-                 (* (d/dt (snd e1)) dt/ds)])--de1/ds-;[(/ (+ (* (y' t)^2 (x'' t))-;       (* -1 (y' t) (y'' t) (x' t)))-;    (+ (x' t)^4 (* 2 (y' t)^2 (x' t)^2) (y' t)^4))-; (/ (+ (* (x' t)^2 (y'' t))-;       (* -1 (x' t) (x'' t) (y' t)))-;    (+ (x' t)^4 (* 2 (y' t)^2 (x' t)^2) (y' t)^4))]--(define $K (/ (fst de1/ds) (fst e2)))--K-;(/ (+ (* (y' t) (x'' t) (sqrt (+ (x' t)^2 (y' t)^2)))-;      (* -1 (y'' t) (x' t) (sqrt (+ (x' t)^2 (y' t)^2))))-;   (+ (* -1 (x' t)^4) (* -2 (y' t)^2 (x' t)^2) (* -1 (y' t)^4)))
− sample/math/geometry/euler-form-of-S2.egi 
@@ -1,74 +0,0 @@-;;; Parameters--(define $x [| θ φ |])--(define $X [|(* r (sin θ) (cos φ)) ; = x-             (* r (sin θ) (sin φ)) ; = y-             (* r (cos θ))         ; = z-             |])--;;; Local basis--(define $e ((flip ∂/∂) x~# X_#))-e-;[|[|(* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |]-;  [|(* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |]-;  |]_#~#--;;; Metric tensor--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {2 2}))-(define $g~~ (M.inverse g_#_#))--g_#_#;[| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |]_#_#-g~#~#;[| [| (/ 1 r^2) 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) |] |]~#~#--;;; Christoffel symbols--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--;;; Connection form--(define $d-  (lambda [%A]-    !((flip ∂/∂) x A)))--(define $ω0 Γ~#_#_#)-ω0~#_#_1;[| [| 0 0 |] [| 0 (/ (cos θ) (sin θ)) |] |]~#_#-ω0~#_#_2;[| [| 0 (* -1 (sin θ) (cos θ)) |] [| (/ (cos θ) (sin θ)) 0 |] |]~#_#--(define $A [|[| (/ 1 r) 0 |] [| 0 (/ 1 (* r (sin θ))) |]|])--(define $ω (+ (. (M.inverse A)~i_j ω0~j_k A~k_l) (. (M.inverse A)~i_j (d A~j_l))))-ω~#_#_1;[| [| 0 0 |] [| 0 0 |] |]~#_#-ω~#_#_2;[| [| 0 (* -1 (cos θ)) |] [| (cos θ) 0 |] |]~#_#--;;; Curvature form--(define $wedge-  (lambda [%X %Y]-    !(. X Y)))--(define $Ω-  (with-symbols {i j k}-    (df-normalize (+ (d ω~i_j)-                     (wedge ω~i_k ω~k_j)))))-Ω~#_#_1_2;[| [| 0 (sin θ) |] [| (* -1 (sin θ)) 0 |] |]~#_#-Ω~#_#_2_1;[| [| 0 (* -1 (sin θ)) |] [| (sin θ) 0 |] |]~#_#-Ω~1_2;[| [| 0 (sin θ) |] [| (* -1 (sin θ)) 0 |] |]-Ω~2_1;[| [| 0 (* -1 (sin θ)) |] [| (sin θ) 0 |] |]--;;; Euler form--(define $euler-form (* (/ 1 (* 2 π)) (- Ω~1_2 Ω~2_1)))--euler-form;[| [| 0 (/ (sin θ) (* 2 π)) |] [| (/ (* -1 (sin θ)) (* 2 π)) 0 |] |]--; χ(S^2) = ∫ dθ dφ (/ (sin θ) (* 2 π)) = ∫ dθ (sin θ)-; = [ (* -1 (cos θ)) ] 0-π = (cos 0) - (cos π) = 2
− sample/math/geometry/euler-form-of-T2.egi 
@@ -1,74 +0,0 @@-;;; Parameters--(define $x [| θ φ |])--(define $X [|(* '(+ (* a (cos θ)) b) (cos φ)) ; = x-             (* '(+ (* a (cos θ)) b) (sin φ)) ; = y-             (* a (sin θ))                    ; = z-             |])--;;; Local basis--(define $e ((flip ∂/∂) x~# X_#))-e-;[|[| (* -1 a (sin θ) (cos φ)) (* -1 a (sin θ) (sin φ)) (* a (cos θ)) |]-;  [| (* -1 '(+ (* a (cos θ)) b) (sin φ)) (* '(+ (* a (cos θ)) b) (cos φ)) 0 |]-;  |]~#~#--;;; Metric tensor--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {2 2}))-(define $g~~ (M.inverse g_#_#))--g_#_#;[| [| a^2 0 |] [| 0 '(+ (* a (cos θ)) b)^2 |] |]_#_#-g~#~#;[| [| (/ 1 a^2) 0 |] [| 0 (/ 1 '(+ (* a (cos θ)) b)^2) |] |]~#~#--;;; Christoffel symbols--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--;;; Connection form--(define $d-  (lambda [%A]-    !((flip ∂/∂) x A)))--(define $ω0 Γ~#_#_#)-ω0~#_#_1;[| [| 0 0 |] [| 0 (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) |] |]~#_#-ω0~#_#_2;[| [| 0 (/ (* '(+ (* a (cos θ)) b) (sin θ)) a) |] [| (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) 0 |] |]~#_#--(define $A [|[| (/ 1 a) 0 |] [| 0 (/ 1 '(+ (* a (cos θ)) b)) |]|])--(define $ω (+ (. (M.inverse A)~i_j ω0~j_k A~k_l) (. (M.inverse A)~i_j (d A~j_l))))-ω~#_#_1;[| [| 0 0 |] [| 0 0 |] |]~#_#-ω~#_#_2;[| [| 0 (sin θ) |] [| (* -1 (sin θ)) 0 |] |]~#_#--;;; Curvature form--(define $wedge-  (lambda [%X %Y]-    !(. X Y)))--(define $Ω-  (with-symbols {i j}-    (df-normalize (+ (d ω~i_j)-                     (wedge ω~i_k ω~k_j)))))-Ω~#_#_1_2;[| [| 0 (cos θ) |] [| (* -1 (cos θ)) 0 |] |]~#_#-Ω~#_#_2_1;[| [| 0 (* -1 (cos θ)) |] [| (cos θ) 0 |] |]~#_#-Ω~1_2;[| [| 0 (cos θ) |] [| (* -1 (cos θ)) 0 |] |]-Ω~2_1;[| [| 0 (* -1 (cos θ)) |] [| (cos θ) 0 |] |]--;;; Euler form--(define $euler-form (* (/ 1 (* 2 π)) (- Ω~1_2 Ω~2_1)))--euler-form;[| [| 0 (/ (cos θ) (* 2 π)) |] [| (/ (* -1 (cos θ)) (* 2 π)) 0 |] |]--; χ(T^2) = ∫ dθ dφ (/ (cos θ) (* 2 π)) = ∫ dθ (cos θ)-; = [ (sin θ) ] 0-π = (sin π) - (sin 0) = 0
− sample/math/geometry/exterior-derivative.egi 
@@ -1,16 +0,0 @@-(define $N 3)-(define $params [| x y z |])-(define $g [| [| 1 0 0 |] [| 0 1 0 |] [| 0 0 1 |] |])--(define $d-  (lambda [%X]-    !((flip ∂/∂) params X)))---(define $f (function [x y z]))--(d f)-;[| f|x f|y f|z |]--(df-normalize (d (d f)))-;[| [| 0 0 0 |] [| 0 0 0 |] [| 0 0 0 |] |]
− sample/math/geometry/hodge-E3.egi 
@@ -1,22 +0,0 @@-(define $N 3)-(define $params [| x y z |])-(define $g [| [| 1 0 0 |] [| 0 1 0 |] [| 0 0 1 |] |])--(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {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] (between 1 k))))))))--(define $dx [| 1 0 0 |])-(define $dy [| 0 1 0 |])-(define $dz [| 0 0 1 |])--(hodge dx)-;[| [| 0 0 0 |] [| 0 0 1 |] [| 0 0 0 |] |] = (wedge dy dz)--(hodge (wedge dx dy))-;[| 0 0 1 |] = dz
− sample/math/geometry/hodge-Minkowski.egi 
@@ -1,25 +0,0 @@-(define $N 4)-(define $params [| t x y z |])-(define $g [| [| -1 0 0 0 |] [| 0 1 0 0 |] [| 0 0 1 0 |] [| 0 0 0 1 |] |])--(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {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] (between 1 k))))))))--(define $dt [| 1 0 0 0 |])-(define $dx [| 0 1 0 0 |])-(define $dy [| 0 0 1 0 |])-(define $dz [| 0 0 0 1 |])--(hodge (wedge dt dx))-;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 -1 |] [| 0 0 0 0 |] |]-;= (* -1 (wedge dy dz))--(hodge (wedge dy dz))-;[| [| 0 1 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]-;= (wedge dt dx)
− sample/math/geometry/hodge-laplacian-E3.egi 
@@ -1,53 +0,0 @@-;;; Parameters and metrics--(define $N 2)--(define $params [|x y|])--(define $g__ [| [| 1 0 |] [| 0 1 |] |])-(define $g~~ (M.inverse g_#_#))--;;; Hodge Laplacian--(define $d-  (lambda [%X]-    !((flip ∂/∂) params X)))--(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {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] (between 1 k))))))))--(define $δ-  (lambda [%A]-    (let {[$k (df-order A)]}-      (* (** -1 (+ (* N (+ k 1)) 1))-         (hodge (d (hodge A)))))))--(define $Δ-  (lambda [%A]-    (match (df-order A) integer-      {[,0 (δ (d A))]-       [,2 (d (δ A))]-       [_ (+ (d (δ A)) (δ (d A)))]})))--(define $f (function [x y]))--(d f)-;[| f|x f|y |]--(hodge (d f))-;[| (* -1 f|y) f|x |]--(d (hodge (d f)))-;[| [| (* -1 f|y|x) f|x|x |] [| (* -1 f|y|y) f|x|y |] |]--(hodge (d (hodge (d f))))-;(+ f|y|y f|x|x)--(Δ f)-;(+ (* -1 f|y|y) (* -1 f|x|x))
− sample/math/geometry/hodge-laplacian-one-form.egi 
@@ -1,52 +0,0 @@-;;; Parameters and metrics--(define $N 3)--(define $params [| x y z |])--(define $g__ [| [| 1 0 0 |] [| 0 1 0 |] [| 0 0 1 |] |])-(define $g~~ (M.inverse g_#_#))--;;; Hodge Laplacian--(define $d-  (lambda [%X]-    !((flip ∂/∂) params X)))--(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {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] (between 1 k))))))))--(define $δ-  (lambda [%A]-    (let {[$r (df-order A)]}-      (* (** -1 (+ (* N r) 1))-         (hodge (d (hodge A)))))))--(define $Δ-  (lambda [%A]-    (match (df-order A) integer-      {[,0 (δ (d A))]-       [,3 (d (δ A))]-       [_ (+ (d (δ A)) (δ (d A)))]})))--(define $ux (function [t x y z]))-(define $uy (function [t x y z]))-(define $uz (function [t x y z]))-(define $u [| ux uy uz |])--(Δ u)-;[| (+ ux|x|x ux|z|z ux|y|y) (+ uy|y|y uy|z|z uy|x|x) (+ uz|z|z uz|y|y uz|x|x) |]--(define $vx (function [t x y z]))-(define $vy (function [t x y z]))-(define $vz (function [t x y z]))-(define $v [|[| 0 vz (* -1 vy) |] [| (* -1 vz) 0 vx |] [| vy (* -1 vx) 0 |]|])--(df-normalize (Δ v))-;[| [| 0 (+ vz|x|x vz|z|z vz|y|y) (+ (* -1 vy|x|x) (* -1 vy|y|y) (* -1 vy|z|z)) |] [| (+ (* -1 vz|y|y) (* -1 vz|x|x) (* -1 vz|z|z)) 0 (+ vx|y|y vx|x|x vx|z|z) |] [| (+ vy|z|z vy|x|x vy|y|y) (+ (* -1 vx|z|z) (* -1 vx|y|y) (* -1 vx|x|x)) 0 |] |]
sample/math/geometry/hodge-laplacian-polar.egi view
@@ -1,53 +1,37 @@-;;; Parameters and metrics+-- Parameters and metrics -(define $N 2)+N := 2 -(define $x [|r θ|])+x := [|r, θ|] -(define $g__ [| [| 1 0 |] [| 0 r^2 |] |])-(define $g~~ (M.inverse g_#_#))+g_i_j := [| [| 1, 0 |], [| 0, r^2 |] |]_i_j+g~i~j := [| [| 1, 0 |], [| 0, 1 / r^2 |] |]~i~j -;;; Hodge Laplacian+-- Hodge Laplacian -(define $d-  (lambda [%X]-    !((flip ∂/∂) x X)))+d %A := !(flip ∂/∂) x A -(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {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] (between 1 k))))))))+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])) -(define $δ-  (lambda [%A]-    (let {[$k (df-order A)]}-      (* (** -1 (+ (* N (+ k 1)) 1))-         (hodge (d (hodge A))))))) -(define $Δ-  (lambda [%A]-    (match (df-order A) integer-      {[,0 (δ (d A))]-       [,2 (d (δ A))]-       [_ (+ (d (δ A)) (δ (d A)))]})))--(define $f (function [r θ]))+δ %A :=+  let k := dfOrder A in+    -1^(N * (k + 1) + 1) * (hodge (d (hodge A))) -(d f)-;[| f|r f|θ |]+Δ %A :=+  match (dfOrder A) as integer with+  | #0 -> δ (d A)+  | #N -> d (δ A)+  | _  -> d (δ A) + δ (d A) -(hodge (d f))-;[| (/ (* -1 f|θ) r) (* r f|r) |]+f := function (r, θ) -(d (hodge (d f)))-;[| [| (/ (+ (* -1 f|θ|r r) f|θ) r^2) (+ f|r (* r f|r|r)) |] [| (/ (* -1 f|θ|θ) r) (* r f|r|θ) |] |]+assertEqual "exterior derivative" (d f) [| ∂/∂ f r, ∂/∂ f θ |] -(hodge (d (hodge (d f))))-;(/ (+ f|θ|θ (* r f|r) (* r^2 f|r|r)) r^2)+assertEqual "hodge operator" (hodge (d f)) [| (-1 * ∂/∂ f θ) / r, r * (∂/∂ f r) |] -(Δ f)-;(/ (+ (* -1 f|θ|θ) (* -1 r f|r) (* -1 r^2 f|r|r)) r^2)+assertEqual "Laplacian" (Δ f) ((-1 / r^2) * ((∂/∂ (∂/∂ f θ) θ) + r * (∂/∂ f r) + (r^2 * (∂/∂ (∂/∂ f r) r))))
− sample/math/geometry/hodge-laplacian-spherical.egi 
@@ -1,46 +0,0 @@-;;; Parameters and metrics--(define $N 3)--(define $x [|r θ φ|])--(define $g__ [| [| 1 0 0 |] [| 0 r^2 0 |] [| 0 0 (* r^2 (sin θ)^2) |] |])-(define $g~~ (M.inverse g_#_#))--;;; Hodge Laplacian--(define $d-  (lambda [%X]-    !((flip ∂/∂) x X)))--(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {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] (between 1 k))))))))--(define $δ-  (lambda [%A]-    (let {[$r (df-order A)]}-      (* (** -1 (+ (* N r) 1))-         (hodge (d (hodge A)))))))--(define $Δ-  (lambda [%A]-    (match (df-order A) integer-      {[,0 (δ (d A))]-       [,N (d (δ A))]-       [_ (+ (d (δ A)) (δ (d A)))]})))--(Δ (f r θ φ))-;(/ (+ (f|3|3 r θ φ) (* (sin θ) (cos θ) (f|2 r θ φ)) (* (sin θ)^2 (f|2|2 r θ φ)) (* 2 r (sin θ)^2 (f|1 r θ φ)) (* r^2 (sin θ)^2 (f|1|1 r θ φ))) (* (sin θ)^2 r^2))-;=-;(/ (+ (* r^2 (sin θ)^2 (f|1|1 r θ φ))-;      (* 2 r (sin θ)^2 (f|1 r θ φ))-;      (* (sin θ) (cos θ) (f|2 r θ φ))-;      (* (sin θ)^2 (f|2|2 r θ φ))-;      (f|3|3 r θ φ))-;   (* (sin θ)^2 r^2))
− sample/math/geometry/hodge-laplacian.egi 
@@ -1,43 +0,0 @@-;;; Parameters and metrics--(define $N 2)--(define $params [|x y|])--(define $g__ [| [| (G_1_1 x y) (G_1_2 x y) |] [| (G_2_1 x y) (G_2_2 x y) |] |])-(define $g~~ [| [| (G~1~1 x y) (G~1~2 x y) |] [| (G~2~1 x y) (G~2~2 x y) |] |])--;;; Hodge Laplacian--(define $d-  (lambda [%X]-    !((flip ∂/∂) params X)))--(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {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] (between 1 k))))))))--(define $δ-  (lambda [%A]-    (let {[$r (df-order A)]}-      (* (** -1 (+ (* N r) 1))-         (hodge (d (hodge A)))))))--(define $Δ-  (lambda [%A]-    (match (df-order A) integer-      {[,0 (δ (d A))]-       [,2 (d (δ A))]-       [_ (+ (d (δ A)) (δ (d A)))]})))--(d (f x y))-(hodge (d (f x y)))-(d (hodge (d (f x y))))-(δ (d (f x y)))-(Δ (f x y))-;
− sample/math/geometry/k143.egi 
@@ -1,27 +0,0 @@-(define $params [| r θ |])--(define $d-  (lambda [%X]-    !((flip ∂/∂) params X)))--(define $wedge-  (lambda [%X %Y]-    !(. X Y)))--(define $u-  (lambda [$r $θ]-    (* r (** e (* 2 π i θ)))))--(define $ū-  (lambda [$r $θ]-    (* r (** e (* -2 π i θ)))))--(d (u r θ))-;[| (exp (* 2 π θ i)) (* 2 r (exp (* 2 π θ i)) π i) |]--(d (ū r θ))-;;[| (exp (* -2 π θ i)) (* -2 r (exp (* -2 π θ i)) π i) |]--(df-normalize (wedge (d (u r θ))-                     (d (ū r θ))))-;[| [| 0 (* -2 r π i) |] [| (* 2 r π i) 0 |] |]
− sample/math/geometry/lie.egi 
@@ -1,48 +0,0 @@-(define $N 3)-(define $params [| x y z |])-(define $g [| [| 1 0 0 |] [| 0 1 0 |] [| 0 0 1 |] |])--(define $d-  (lambda [%X]-    !((flip ∂/∂) params X)))--(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {i j}-        (* (sqrt (abs (M.det g_#_#)))-           (foldl . (. A_[j_1]..._[j_k]-                       (ε' N k)_[i_1]..._[i_N])-                  (map 1#g~[i_%1]~[j_%1] (between 1 k))))))))--(define $dx [| 1 0 0 |])-(define $dy [| 0 1 0 |])-(define $dz [| 0 0 1 |])--(define $ι-  (lambda [%X %Y]-    (with-symbols {i}-      (* (df-order Y) (. X...~i (df-normalize Y..._i))))))--(define $Lie-  (lambda [%X %Y]-    (match (df-order Y) integer-      {[,0 (ι X (d Y))]-       [,N (d (ι X Y))]-       [_ (+ (ι X (d Y)) (d (ι X Y)))]})))--(define $ρ (function [t x y z]))-(define $*ρ (df-normalize (hodge ρ)))--(define $u_ (generate-tensor 1#(function [t x y z]) {3}))-(define $u [| u_1 u_2 u_3 |])--(df-normalize (+ (∂/∂ *ρ t) (Lie u *ρ)))-;(tensor {3 3 3} {0 0 0 0 0 (/ (+ ρ|t (* u_1|x ρ) (* u_1 ρ|x) (* u_2|y ρ) (* u_2 ρ|y) (* u_3|z ρ) (* u_3 ρ|z)) 6) 0 (/ (+ (* -1 ρ|t) (* -1 u_1|x ρ) (* -1 u_1 ρ|x) (* -1 u_3|z ρ) (* -1 u_3 ρ|z) (* -1 u_2|y ρ) (* -1 u_2 ρ|y)) 6) 0 0 0 (/ (+ (* -1 ρ|t) (* -1 u_2|y ρ) (* -1 u_2 ρ|y) (* -1 u_1|x ρ) (* -1 u_1 ρ|x) (* -1 u_3|z ρ) (* -1 u_3 ρ|z)) 6) 0 0 0 (/ (+ ρ|t (* u_2|y ρ) (* u_2 ρ|y) (* u_3|z ρ) (* u_3 ρ|z) (* u_1|x ρ) (* u_1 ρ|x)) 6) 0 0 0 (/ (+ ρ|t (* u_3|z ρ) (* u_3 ρ|z) (* u_1|x ρ) (* u_1 ρ|x) (* u_2|y ρ) (* u_2 ρ|y)) 6) 0 (/ (+ (* -1 ρ|t) (* -1 u_3|z ρ) (* -1 u_3 ρ|z) (* -1 u_2|y ρ) (* -1 u_2 ρ|y) (* -1 u_1|x ρ) (* -1 u_1 ρ|x)) 6) 0 0 0 0 0} )--(df-normalize (+ (∂/∂ *ρ t) (Lie u *ρ)))_1_2_3-;(/ (+ ρ|t-;      (* u_1|x ρ) (* u_1 ρ|x)-;      (* u_2|y ρ) (* u_2 ρ|y)-;      (* u_3|z ρ) (* u_3 ρ|z))-;   6)
− sample/math/geometry/polar-laplacian-2d-2.egi 
@@ -1,68 +0,0 @@-;;;-;;; Polar coordinates-;;;--(define $x [|r θ|])--(define $X [|(* r (cos θ)) ; = x-             (* r (sin θ)) ; = y-             |])--;;-;; Local coordinates-;;--(define $e ((∂/∂ X_# $) x~#))-e-;[| [| (cos θ) (sin θ) |] [| (* -1 r (sin θ)) (* r (cos θ)) |] |]--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {2 2}))-(define $g~~ (with-symbols {i j} (/ (unit-tensor {2 2})_i_j g_i_j)))--g_#_#;[| [| 1 0 |] [| 0 r^2 |] |]_#_#-g~#~#;[| [| 1 0 |] [| 0 (/ 1 r^2) |] |]~#~#--;;-;; Christoffel symbols of the first kind-;;--(define $Γ___-  (with-symbols {j k l}-    (* (/ 1 2)-       (+ (∂/∂ g_j_l x~k)-          (∂/∂ g_j_k x~l)-          (* -1 (∂/∂ g_k_l x~j))))))--Γ_#_#_#;(tensor {2 2 2} {0 0 0 (* -1 r) 0 r r 0} )_#_#_#-Γ_1_#_#;[| [| 0 0 |] [| 0 (* -1 r) |] |]_#_#-Γ_2_#_#;[| [| 0 r |] [| r 0 |] |]_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__-  (with-symbols {i j k l}-    (. g~i~j Γ_j_k_l)))--Γ~#_#_#;(tensor {2 2 2} {0 0 0 (* -1 r) 0 (/ 1 r) (/ 1 r) 0} )~#_#_#-Γ~1_#_#;[| [| 0 0 |] [| 0 (* -1 r) |] |]_#_#-Γ~2_#_#;[| [| 0 (/ 1 r) |] [| (/ 1 r) 0 |] |]_#_#--;;-;; Derive Laplacian-;;--(. g~i~j (∂/∂ (∂/∂ (f r θ) x~j) x~i))-;(/ (+ (* (f|1|1 r θ) r^2) (f|2|2 r θ)) r^2)-(. (. g~i~j Γ~k_i_j) (∂/∂ (f r θ) x~k))-;(/ (* -1 (f|1 r θ)) r)--(define $Laplacian (- (. g~i~j (∂/∂ (∂/∂ (f r θ) x~j) x~i))-                        (. (. g~i~j Γ~k_i_j) (∂/∂ (f r θ) x~k))))-Laplacian-;(/ (+ (* (f|1|1 r θ) r^2) (f|2|2 r θ) (* (f|1 r θ) r)) r^2)
− sample/math/geometry/polar-laplacian-2d-3.egi 
@@ -1,38 +0,0 @@-;;;-;;; Polar coordinates-;;;--(define $x [|r θ|])--(define $X [|(* r (cos θ)) ; = x-             (* r (sin θ)) ; = y-             |])--;;-;; Local coordinates-;;--(define $e ((∂/∂ X_# $) x~#))-e-;[| [| (cos θ) (sin θ) |] [| (* -1 r (sin θ)) (* r (cos θ)) |] |]--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {2 2}))-(define $g~~ (with-symbols {i j} (/ (unit-tensor {2 2})_i_j g_i_j)))--g_#_#;[| [| 1 0 |] [| 0 r^2 |] |]_#_#-g~#~#;[| [| 1 0 |] [| 0 (/ 1 r^2) |] |]~#~#--;;-;; Derive Laplacian-;;--(define $sqrt-g (sqrt (M.det g_#_#)))-sqrt-g;r--(define $Laplacian (/ (contract + (∂/∂ (* sqrt-g (. g~i~j (∂/∂ (f r θ) x~j))) x~i)) sqrt-g))-Laplacian-;(/ (+ (* (f|1 r θ) r) (* r^2 (f|1|1 r θ)) (f|2|2 r θ)) r^2)
− sample/math/geometry/polar-laplacian-2d.egi 
@@ -1,39 +0,0 @@-(define $x (* r (cos θ)))-(define $y (* r (sin θ)))--(define $u-r (∂/∂ (u x y) r))-u-r-;(+ (* (u|1 (* r (cos θ)) (* r (sin θ))) (cos θ))-;   (* (u|2 (* r (cos θ)) (* r (sin θ))) (sin θ)))--(define $u-r-r (∂/∂ (∂/∂ (u x y) r) r))-u-r-r-;(+ (* (u|1|1 (* r (cos θ)) (* r (sin θ))) (cos θ)^2)-;   (* (u|1|2 (* r (cos θ)) (* r (sin θ))) (sin θ) (cos θ))-;   (* (u|2|1 (* r (cos θ)) (* r (sin θ))) (cos θ) (sin θ))-;   (* (u|2|2 (* r (cos θ)) (* r (sin θ))) (sin θ)^2))--(define $u-θ (∂/∂ (u x y) θ))-u-θ-;(+ (* -1 (u|1 (* r (cos θ)) (* r (sin θ))) r (sin θ))-;   (* (u|2 (* r (cos θ)) (* r (sin θ))) r (cos θ)))--(define $u-θ-θ (∂/∂ (∂/∂ (u x y) θ) θ))-u-θ-θ-;(+ (* (u|1|1 (* r (cos θ)) (* r (sin θ))) r^2 (sin θ)^2)-;   (* -1 (u|1|2 (* r (cos θ)) (* r (sin θ))) r^2 (cos θ) (sin θ))-;   (* -1 (u|1 (* r (cos θ)) (* r (sin θ))) r (cos θ))-;   (* -1 (u|2|1 (* r (cos θ)) (* r (sin θ))) r^2 (sin θ) (cos θ))-;   (* (u|2|2 (* r (cos θ)) (* r (sin θ))) r^2 (cos θ)^2)-;   (* -1 (u|2 (* r (cos θ)) (* r (sin θ))) r (sin θ)))--(+ u-r-r (* (/ 1 (** r 2)) u-θ-θ))-;(/ (+ (* -1 (u|1 (* r (cos θ)) (* r (sin θ))) (cos θ))-;      (* -1 (u|2 (* r (cos θ)) (* r (sin θ))) (sin θ))-;      (* (u|1|1 (* r (cos θ)) (* r (sin θ))) r)-;      (* (u|2|2 (* r (cos θ)) (* r (sin θ))) r))-;   r)--(+ u-r-r (* (/ 1 r) u-r) (* (/ 1 (** r 2)) u-θ-θ))-;(+ (u|1|1 (* r (cos θ)) (* r (sin θ)))-;   (u|2|2 (* r (cos θ)) (* r (sin θ))))
− sample/math/geometry/polar-laplacian-3d-2.egi 
@@ -1,73 +0,0 @@-;;;-;;; Spherical coordinates-;;;--(define $x [|r θ φ|])--(define $X [|(* r (sin θ) (cos φ)) ; = x-             (* r (sin θ) (sin φ)) ; = y-             (* r (cos θ))         ; = z-             |])--;;-;; Local coordinates-;;--(define $e ((∂/∂ X_# $) x~#))-e-;[|[| (* (sin θ) (cos φ)) (* (sin θ) (sin φ)) (cos θ) |]-;  [| (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |]-;  [| (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |]|]--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {3 3}))-(define $g~~ (with-symbols {i j} (/ (unit-tensor {3 3})_i_j g_i_j)))--g_#_#;[| [| 1 0 0 |] [| 0 r^2 0 |] [| 0 0 (* r^2 (sin θ)^2) |] |]_#_#-g~#~#;[| [| 1 0 0 |] [| 0 (/ 1 r^2) 0 |] [| 0 0 (/ 1 (* r^2 (sin θ)^2)) |] |]~#~#--;;-;; Christoffel symbols of the first kind-;;--(define $Γ___-  (with-symbols {j k l}-    (* (/ 1 2)-       (+ (∂/∂ g_j_l x~k)-          (∂/∂ g_j_k x~l)-          (* -1 (∂/∂ g_k_l x~j))))))--Γ_#_#_#;(tensor {3 3 3} {0 0 0 0 (* -1 r) 0 0 0 (* -1 r (sin θ)^2) 0 r 0 r 0 0 0 0 (* -1 r^2 (sin θ) (cos θ)) 0 0 (* r (sin θ)^2) 0 0 (* r^2 (sin θ) (cos θ)) (* r (sin θ)^2) (* r^2 (sin θ) (cos θ)) 0} )_#_#_#-Γ_1_#_#;[| [| 0 0 0 |] [| 0 (* -1 r) 0 |] [| 0 0 (* -1 r (sin θ)^2) |] |]_#_#-Γ_2_#_#;[| [| 0 r 0 |] [| r 0 0 |] [| 0 0 (* -1 r^2 (sin θ) (cos θ)) |] |]_#_#-Γ_3_#_#;[| [| 0 0 (* r (sin θ)^2) |] [| 0 0 (* r^2 (sin θ) (cos θ)) |] [| (* r (sin θ)^2) (* r^2 (sin θ) (cos θ)) 0 |] |]_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__-  (with-symbols {i j k l}-    (. g~i~j Γ_j_k_l)))--Γ~#_#_#;(tensor {3 3 3} {0 0 0 0 (* -1 r) 0 0 0 (* -1 r (sin θ)^2) 0 (/ 1 r) 0 (/ 1 r) 0 0 0 0 (* -1 (sin θ) (cos θ)) 0 0 (/ 1 r) 0 0 (/ (cos θ) (sin θ)) (/ 1 r) (/ (cos θ) (sin θ)) 0} )~#_#_#-Γ~1_#_#;[| [| 0 0 0 |] [| 0 (* -1 r) 0 |] [| 0 0 (* -1 r (sin θ)^2) |] |]_#_#-Γ~2_#_#;[| [| 0 (/ 1 r) 0 |] [| (/ 1 r) 0 0 |] [| 0 0 (* -1 (sin θ) (cos θ)) |] |]_#_#-Γ~3_#_#;[| [| 0 0 (/ 1 r) |] [| 0 0 (/ (cos θ) (sin θ)) |] [| (/ 1 r) (/ (cos θ) (sin θ)) 0 |] |]_#_#--;;-;; Laplacian-;;--(. g~i~j (∂/∂ (∂/∂ (f r θ φ) x~j) x~i))-;(/ (+ (* (f|1|1 r θ φ) r^2 (sin θ)^2) (* (f|2|2 r θ φ) (sin θ)^2) (f|3|3 r θ φ)) (* r^2 (sin θ)^2))-(. (. g~i~j Γ~k_i_j) (∂/∂ (f r θ φ) x~k))-;(/ (+ (* -2 (f|1 r θ φ) r (sin θ)) (* -1 (cos θ) (f|2 r θ φ))) (* r^2 (sin θ)))--(define $Laplacian (- (. g~i~j (∂/∂ (∂/∂ (f r θ φ) x~j) x~i))-                        (. (. g~i~j Γ~k_i_j) (∂/∂ (f r θ φ) x~k))))-Laplacian-;(/ (+ (* (f|1|1 r θ φ) r^2 (sin θ)^2) (* (f|2|2 r θ φ) (sin θ)^2) (f|3|3 r θ φ) (* 2 (f|1 r θ φ) r (sin θ)^2) (* (cos θ) (f|2 r θ φ) (sin θ))) (* r^2 (sin θ)^2))
− sample/math/geometry/polar-laplacian-3d-3.egi 
@@ -1,41 +0,0 @@-;;;-;;; Spherical coordinates-;;;--(define $x [|r θ φ|])--(define $X [|(* r (sin θ) (cos φ)) ; = x-             (* r (sin θ) (sin φ)) ; = y-             (* r (cos θ))         ; = z-             |])--;;-;; Local coordinates-;;--(define $e ((∂/∂ X_# $) x~#))-e-;[|[| (* (sin θ) (cos φ)) (* (sin θ) (sin φ)) (cos θ) |]-;  [| (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |]-;  [| (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |]|]--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {3 3}))-(define $g~~ (with-symbols {i j} (/ (unit-tensor {3 3})_i_j g_i_j)))--g_#_#;[| [| 1 0 0 |] [| 0 r^2 0 |] [| 0 0 (* r^2 (sin θ)^2) |] |]_#_#-g~#~#;[| [| 1 0 0 |] [| 0 (/ 1 r^2) 0 |] [| 0 0 (/ 1 (* r^2 (sin θ)^2)) |] |]~#~#--;;-;; Laplacian-;;--(define $sqrt-g (sqrt (M.det g_#_#)))-sqrt-g;(* r^2 (sin θ))--(define $Laplacian (/ (contract + (∂/∂ (* sqrt-g (. g~i~j (∂/∂ (f r θ φ) x~j))) x~i)) sqrt-g))-Laplacian-;(/ (+ (* 2 r (sin θ)^2 (f|1 r θ φ)) (* r^2 (sin θ)^2 (f|1|1 r θ φ)) (* (cos θ) (f|2 r θ φ) (sin θ)) (* (sin θ)^2 (f|2|2 r θ φ)) (f|3|3 r θ φ)) (* (sin θ)^2 r^2))
− sample/math/geometry/polar-laplacian-3d.egi 
@@ -1,61 +0,0 @@-(define $x (* r (sin θ) (cos φ)))-(define $y (* r (sin θ) (sin φ)))-(define $z (* r (cos θ)))--(define $u-r (∂/∂ (u x y z) r))-u-r-;(+ (* (u|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (sin θ) (cos φ))-;   (* (u|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (sin θ) (sin φ))-;   (* (u|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (cos θ)))--(define $u-r-r (∂/∂ (∂/∂ (u x y z) r) r))-u-r-r-;(+ (* (u|1|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (sin θ)^2 (cos φ)^2)-;   (* (u|1|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (sin θ)^2 (sin φ) (cos φ))-;   (* (u|1|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (cos θ) (sin θ) (cos φ))-;   (* (u|2|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (sin θ)^2 (cos φ) (sin φ))-;   (* (u|2|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (sin θ)^2 (sin φ)^2)-;   (* (u|2|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (cos θ) (sin θ) (sin φ))-;   (* (u|3|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (sin θ) (cos φ) (cos θ))-;   (* (u|3|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (sin θ) (sin φ) (cos θ))-;   (* (u|3|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) (cos θ)^2))--(define $u-θ (∂/∂ (u x y z) θ))-u-θ-;(+ (* (u|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (cos θ) (cos φ))-;   (* (u|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (cos θ) (sin φ))-;   (* -1 (u|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (sin θ)))--(define $u-θ-θ (∂/∂ (∂/∂ (u x y z) θ) θ))-u-θ-θ-;(+ (* (u|1|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (cos θ)^2 (cos φ)^2)-;   (* (u|1|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (cos θ)^2 (sin φ) (cos φ))-;   (* -1 (u|1|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (sin θ) (cos θ) (cos φ))-;   (* -1 (u|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (sin θ) (cos φ))-;   (* (u|2|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (cos θ)^2 (cos φ) (sin φ))-;   (* (u|2|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (cos θ)^2 (sin φ)^2)-;   (* -1 (u|2|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (sin θ) (cos θ) (sin φ))-;   (* -1 (u|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (sin θ) (sin φ))-;   (* -1 (u|3|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (cos θ) (cos φ) (sin θ))-;   (* -1 (u|3|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (cos θ) (sin φ) (sin θ))-;   (* (u|3|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (sin θ)^2)-;   (* -1 (u|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (cos θ)))--(define $u-φ (∂/∂ (u x y z) φ))-u-φ-;(+ (* -1 (u|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (sin θ) (sin φ))-;   (* (u|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (sin θ) (cos φ)))--(define $u-φ-φ (∂/∂ (∂/∂ (u x y z) φ) φ))-u-φ-φ-;(+ (* (u|1|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (sin θ)^2 (sin φ)^2)-;   (* -1 (u|1|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (sin θ)^2 (cos φ) (sin φ))-;   (* -1 (u|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (sin θ) (cos φ))-;   (* -1 (u|2|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (sin θ)^2 (sin φ) (cos φ))-;   (* (u|2|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r^2 (sin θ)^2 (cos φ)^2)-;   (* -1 (u|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))) r (sin θ) (sin φ)))--(+ u-r-r (* (/ 2 r) u-r) (* (/ 1 (** r 2)) u-θ-θ) (* (/ (cos θ) (* (** r 2) (sin θ))) u-θ) (* (/ 1 (** (* r (sin θ)) 2)) u-φ-φ))-;(+ (u|3|3 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ)))-;   (u|1|1 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ)))-;   (u|2|2 (* r (sin θ) (cos φ)) (* r (sin θ) (sin φ)) (* r (cos θ))))
− sample/math/geometry/riemann-curvature-tensor-of-FLRW-metric.egi 
@@ -1,101 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|w r θ φ|])--;;-;; Metric tensor-;;--(define $W (lambda [$r] (/ 1 '(- 1 (* K r^2)))))--(define $g__-  [|[| -1 0 0 0 |]-    [| 0 (* (`a w)^2 (W r)) 0 0 |]-    [| 0 0 (* (`a w)^2 r^2) 0 |]-    [| 0 0 0 (* (`a w)^2 r^2 (sin θ)^2) |]-    |])--(define $g~~ (M.inverse g_#_#))-g~#~#-;[|[| -1 0 0 0 |]-;  [| 0 (/ (* -1 '(+ 1 (* -1 K r^2))) (* -1 (a w)^2)) 0 0 |]-;  [| 0 0 (/ -1 (* -1 (a w)^2 r^2)) 0 |]-;  [| 0 0 0 (/ -1 (* -1 (a w)^2 r^2 (sin θ)^2)) |]|]~#~#--(with-symbols {i j k} (. g~i~j g_j_k))-;[| [| 1 0 0 0 |] [| 0 1 0 0 |] [| 0 0 1 0 |] [| 0 0 0 1 |] |]--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_k x~l)-        (∂/∂ g_j_l x~k)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_1_#_#;[| [| 0 0 0 0 |] [| 0 (/ (* -1 (a w) (a|1 w)) '(+ 1 (* -1 K r^2))) 0 0 |] [| 0 0 (* -1 (a w) (a|1 w) r^2) 0 |] [| 0 0 0 (* -1 (a w) (a|1 w) r^2 (sin θ)^2) |] |]_#_#-Γ_2_#_#;[| [| 0 (/ (* (a w) (a|1 w)) '(+ 1 (* -1 K r^2))) 0 0 |] [| (/ (* (a w) (a|1 w)) '(+ 1 (* -1 K r^2))) (/ (* K r (a w)^2) '(+ 1 (* -1 K r^2))^2) 0 0 |] [| 0 0 (* -1 (a w)^2 r) 0 |] [| 0 0 0 (* -1 (a w)^2 r (sin θ)^2) |] |]_#_#-Γ_3_#_#;[| [| 0 0 (* (a w) (a|1 w) r^2) 0 |] [| 0 0 (* (a w)^2 r) 0 |] [| (* (a w) (a|1 w) r^2) (* (a w)^2 r) 0 0 |] [| 0 0 0 (* -1 (a w)^2 r^2 (sin θ) (cos θ)) |] |]_#_#-Γ_4_#_#;[| [| 0 0 0 (* (a w) (a|1 w) r^2 (sin θ)^2) |] [| 0 0 0 (* (a w)^2 r (sin θ)^2) |] [| 0 0 0 (* (a w)^2 r^2 (sin θ) (cos θ)) |] [| (* (a w) (a|1 w) r^2 (sin θ)^2) (* (a w)^2 r (sin θ)^2) (* (a w)^2 r^2 (sin θ) (cos θ)) 0 |] |]_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~1_#_#;[| [| 0 0 0 0 |] [| 0 (/ (* (a w) (a|1 w)) '(+ 1 (* -1 K r^2))) 0 0 |] [| 0 0 (* (a w) (a|1 w) r^2) 0 |] [| 0 0 0 (* (a w) (a|1 w) r^2 (sin θ)^2) |] |]_#_#-Γ~2_#_#;[| [| 0 (/ (* -1 (a|1 w)) (* -1 (a w))) 0 0 |] [| (/ (* -1 (a|1 w)) (* -1 (a w))) (/ (* -1 K r) (* -1 '(+ 1 (* -1 K r^2)))) 0 0 |] [| 0 0 (* -1 '(+ 1 (* -1 K r^2)) r) 0 |] [| 0 0 0 (* -1 '(+ 1 (* -1 K r^2)) r (sin θ)^2) |] |]_#_#-Γ~3_#_#;[| [| 0 0 (/ (* -1 (a|1 w)) (* -1 (a w))) 0 |] [| 0 0 (/ -1 (* -1 r)) 0 |] [| (/ (* -1 (a|1 w)) (* -1 (a w))) (/ -1 (* -1 r)) 0 0 |] [| 0 0 0 (* -1 (sin θ) (cos θ)) |] |]_#_#-Γ~4_#_#;[| [| 0 0 0 (/ (* -1 (a|1 w)) (* -1 (a w))) |] [| 0 0 0 (/ -1 (* -1 r)) |] [| 0 0 0 (/ (* -1 (cos θ)) (* -1 (sin θ))) |] [| (/ (* -1 (a|1 w)) (* -1 (a w))) (/ -1 (* -1 r)) (/ (* -1 (cos θ)) (* -1 (sin θ))) 0 |] |]_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_1_1;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_1_2;[| [| 0 (/ (* (a w) (a|1|1 w)) (+ -1 (* K r^2))) 0 0 |] [| (/ (* -1 (a|1|1 w)) (a w)) 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_1_3;[| [| 0 0 (* -1 (a w) (a|1|1 w) r^2) 0 |] [| 0 0 0 0 |] [| (/ (* -1 (a|1|1 w)) (a w)) 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_1_4;[| [| 0 0 0 (* -1 (a w) (a|1|1 w) r^2 (sin θ)^2) |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| (/ (* -1 (a|1|1 w)) (a w)) 0 0 0 |] |]~#_#-R~#_#_2_1;[| [| 0 (/ (* -1 (a w) (a|1|1 w)) (+ -1 (* K r^2))) 0 0 |] [| (/ (a|1|1 w) (a w)) 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_2_2;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_2_3;[| [| 0 0 0 0 |] [| 0 0 (+ (* -1 K r^2) (* -1 (a|1 w)^2 r^2)) 0 |] [| 0 (/ (+ (* -1 (a|1 w)^2) (* -1 K)) (+ -1 (* K r^2))) 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_2_4;[| [| 0 0 0 0 |] [| 0 0 0 (+ (* -1 K r^2 (sin θ)^2) (* -1 (a|1 w)^2 r^2 (sin θ)^2)) |] [| 0 0 0 0 |] [| 0 (/ (+ (* -1 (a|1 w)^2) (* -1 K)) (+ -1 (* K r^2))) 0 0 |] |]~#_#-R~#_#_3_1;[| [| 0 0 (* (a w) (a|1|1 w) r^2) 0 |] [| 0 0 0 0 |] [| (/ (a|1|1 w) (a w)) 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_3_2;[| [| 0 0 0 0 |] [| 0 0 (+ (* K r^2) (* (a|1 w)^2 r^2)) 0 |] [| 0 (/ (+ (a|1 w)^2 K) (+ -1 (* K r^2))) 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_3_3;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_3_4;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 (+ (* -1 (a|1 w)^2 r^2 (sin θ)^2) (* -1 K r^2 (sin θ)^2)) |] [| 0 0 (+ (* (a|1 w)^2 r^2) (* K r^2)) 0 |] |]~#_#-R~#_#_4_1;[| [| 0 0 0 (* (a w) (a|1|1 w) r^2 (sin θ)^2) |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| (/ (a|1|1 w) (a w)) 0 0 0 |] |]~#_#-R~#_#_4_2;[| [| 0 0 0 0 |] [| 0 0 0 (+ (* K r^2 (sin θ)^2) (* (a|1 w)^2 r^2 (sin θ)^2)) |] [| 0 0 0 0 |] [| 0 (/ (+ (a|1 w)^2 K) (+ -1 (* K r^2))) 0 0 |] |]~#_#-R~#_#_4_3;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 (+ (* (a|1 w)^2 r^2 (sin θ)^2) (* K r^2 (sin θ)^2)) |] [| 0 0 (+ (* -1 (a|1 w)^2 r^2) (* -1 K r^2)) 0 |] |]~#_#-R~#_#_4_4;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))--Ric_1_#;[| (/ (* -3 (a|1|1 w)) (a w)) 0 0 0 |]_#-Ric_2_#;[| 0 (/ (+ (* -1 (a w) (a|1|1 w)) (* -2 (a|1 w)^2) (* -2 K)) (+ -1 (* K r^2))) 0 0 |]_#-Ric_3_#;[| 0 0 (+ (* (a w) (a|1|1 w) r^2) (* 2 K r^2) (* 2 (a|1 w)^2 r^2)) 0 |]_#-Ric_4_#;[| 0 0 0 (+ (* (a w) (a|1|1 w) r^2 (sin θ)^2) (* 2 K r^2 (sin θ)^2) (* 2 (a|1 w)^2 r^2 (sin θ)^2)) |]_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (expand-all' (. g~j~k Ric_j_k))))--scalar-curvature-;(/ (+ (* 6 (a|1|1 w) (a w)) (* 6 (a|1 w)^2) (* 6 K))-;   (a w)^2)
− sample/math/geometry/riemann-curvature-tensor-of-M3-conformal.egi 
@@ -1,72 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|α β γ|])--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(* (a α β γ) (G_%1_%2 α β γ)) {3 3}))-(define $g~~ (generate-tensor 2#(* (/ 1 (a α β γ)) (G~%1~%2 α β γ)) {3 3}))-g_#_#-g~#~#--;;-;; Christoffel symbols of the first kind-;;--(define $Γ___-  (with-symbols {j k l}-    (* (/ 1 2)-       (+ (∂/∂ g_j_l x~k)-          (∂/∂ g_j_k x~l)-          (* -1 (∂/∂ g_k_l x~j))))))--Γ_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__-  (with-symbols {i j k l}-    (. g~i~j Γ_j_k_l)))--Γ~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i j k} (contract + R~i_j_k_i)))--Ric_#_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature--;;-;; Wodzicki-Chern-Simons class-;;--(let {[[$es $os] (even-and-odd-permutations 3)]}-  (- (sum (map (lambda [$σ] (. R~u_1_s_(σ 1) R~s_u_(σ 3)_(σ 2))) es))-     (sum (map (lambda [$σ] (. R~u_1_s_(σ 1) R~s_t_(σ 3)_(σ 2))) os))))
− sample/math/geometry/riemann-curvature-tensor-of-M5-conformal.egi 
@@ -1,56 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|α β γ δ ε|])--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(* (a α β γ δ ε) (G_%1_%2 α β γ δ ε)) {5 5}))-(define $g~~ (generate-tensor 2#(* (/ 1 (a α β γ δ ε)) (G~%1~%2 α β γ δ ε)) {5 5}))-g_#_#-g~#~#--;;-;; Christoffel symbols of the first kind-;;--(define $Γ___-  (with-symbols {j k l}-    (* (/ 1 2)-       (+ (∂/∂ g_j_l x~k)-          (∂/∂ g_j_k x~l)-          (* -1 (∂/∂ g_k_l x~j))))))--Γ_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__-  (with-symbols {i j k l}-    (. g~i~j Γ_j_k_l)))--Γ~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#--;;-;; Wodzicki-Chern-Simons class-;;--(let {[[$es $os] (even-and-odd-permutations 5)]}-  (- (sum (map (lambda [$σ] (. R~u_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4))) es))-     (sum (map (lambda [$σ] (. R~u_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4))) os))))
− sample/math/geometry/riemann-curvature-tensor-of-S1.egi 
@@ -1,80 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|θ|])--(define $X [|(* r (sin θ)) ; = x-             (* r (cos θ)) ; = y-             |])--;;-;; Local basis-;;--(define $e ((flip ∂/∂) x~# X_#))-e;[| [| (* r (cos θ)) (* -1 r (sin θ)) |] |]_#~#--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {1 1}))-(define $g~~ (M.inverse g_#_#))--g_#_#;[| [| r^2 |] |]_#_#-g~#~#;[| [| (/ 1 r^2) |] |]~#~#--;;-;; Christoffel symbols of the first kind-;;--(define $Γ___-  (with-symbols {j k l}-    (* (/ 1 2)-       (+ (∂/∂ g_j_k x~l)-          (∂/∂ g_j_l x~k)-          (* -1 (∂/∂ g_k_l x~j))))))--Γ_#_#_#;(tensor {1 1 1} {0} )_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__-  (with-symbols {i j k l}-    (. g~i~j Γ_j_k_l)))--Γ~#_#_#;(tensor {1 1 1} {0} )~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#;(tensor {1 1 1 1} {0} )~#_#_#_#--(define $R____ (with-symbols {i} (. g_i_# R~i_#_#_#)))--R_#_#_#_#;(tensor {1 1 1 1} {0} )_#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i j k} (contract + R~i_j_k_i)))--Ric_#_#;[| [| 0 |] |]_#_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature;0
sample/math/geometry/riemann-curvature-tensor-of-S2.egi view
@@ -1,121 +1,69 @@-;;;-;;; Parameters-;;;--(define $x [|θ φ|])--(define $X [|(* r (sin θ) (cos φ)) ; = x-             (* r (sin θ) (sin φ)) ; = y-             (* r (cos θ))         ; = z-             |])--;;-;; Local basis-;;--(define $e_i_j (∂/∂ X_j x~i))-(assert-equal "Local basis"-  e_#_#-  [|[|(* r (cos θ) (cos φ)) (* r (cos θ) (sin φ)) (* -1 r (sin θ)) |]-    [|(* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ)) 0 |]-    |]_#_#)--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1_# e_%2_#) {2 2}))-(define $g~~ (M.inverse g_#_#))--(assert-equal "Metric tensor 1" g_#_# [| [| r^2 0 |] [| 0 (* r^2 (sin θ)^2) |] |]_#_#)-(assert-equal "Metroc tensor 2" g~#~# [| [| (/ 1 r^2) 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) |] |]~#~#)--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--(assert-equal "Christoffel symbols of the first kind" Γ_#_#_# (tensor {2 2 2} {0 0 0 (* -1 r^2 (sin θ) (cos θ)) 0 (* r^2 (sin θ) (cos θ)) (* r^2 (sin θ) (cos θ)) 0} )_#_#_#)-(assert-equal "Christoffel symbols of the first kind" Γ_1_#_# [| [| 0 0 |] [| 0 (* -1 r^2 (sin θ) (cos θ)) |] |]_#_#)-(assert-equal "Christoffel symbols of the first kind" Γ_2_#_# [| [| 0 (* r^2 (sin θ) (cos θ)) |] [| (* r^2 (sin θ) (cos θ)) 0 |] |]_#_#)--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--(assert-equal "Christoffel symbols of the second kind" Γ~#_#_# (tensor {2 2 2} {0 0 0 (* -1 (sin θ) (cos θ)) 0 (/ (cos θ) (sin θ)) (/ (cos θ) (sin θ)) 0} )~#_#_#)-(assert-equal "Christoffel symbols of the second kind" Γ~1_#_# [| [| 0 0 |] [| 0 (* -1 (sin θ) (cos θ)) |] |]_#_#)-(assert-equal "Christoffel symbols of the second kind" Γ~2_#_# [| [| 0 (/ (cos θ) (sin θ)) |] [| (/ (cos θ) (sin θ)) 0 |] |]_#_#)--;;-;; Covariant derivative of metric tensor-;;-(define $∇g___-  (with-symbols {i j m n}-    (- (∂/∂ g_i_j x~m)-       (. Γ~n_m_i g_n_j)-       (. Γ~n_m_j g_i_n))))--(assert-equal "Covariant derivative of metric tensor" ∇g_#_#_# (tensor {2 2 2} {0 0 0 0 0 0 0 0} ))--;;-;; Riemann curvature tensor-;;+-- Parameters+x := [| θ, φ |] -(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))+X := [| r * sin θ * cos φ -- x+      , r * sin θ * sin φ -- y+      , r * cos θ         -- z+      |] -(assert-equal "Riemann curvature" R~#_#_#_# (tensor {2 2 2 2} {0 0 0 0 0 (sin θ)^2 (* -1 (sin θ)^2) 0 0 -1 1 0 0 0 0 0} )~#_#_#_#)-(assert-equal "Riemann curvature" R~#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]~#_#)-(assert-equal "Riemann curvature" R~#_#_1_2 [| [| 0 (sin θ)^2 |] [| -1 0 |] |]~#_#)-(assert-equal "Riemann curvature" R~#_#_2_1 [| [| 0 (* -1 (sin θ)^2) |] [| 1 0 |] |]~#_#)-(assert-equal "Riemann curvature" R~#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]~#_#)+e_i_j := ∂/∂ X_j x~i -(define $R____ (with-symbols {i} (. g_i_# R~i_#_#_#)))+-- Metric tensors+g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2]+g~i~j := M.inverse g_#_# -(assert-equal "Riemann curvature" R_#_#_#_# (tensor {2 2 2 2} {0 0 0 0 0 (* r^2 (sin θ)^2) (* -1 r^2 (sin θ)^2) 0 0 (* -1 r^2 (sin θ)^2) (* r^2 (sin θ)^2) 0 0 0 0 0} )_#_#_#_#)-(assert-equal "Riemann curvature" R_#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]_#_#)-(assert-equal "Riemann curvature" R_#_#_1_2 [| [| 0 (* r^2 (sin θ)^2) |] [| (* -1 r^2 (sin θ)^2) 0 |] |]_#_#)-(assert-equal "Riemann curvature" R_#_#_2_1 [| [| 0 (* -1 r^2 (sin θ)^2) |] [| (* r^2 (sin θ)^2) 0 |] |]_#_#)-(assert-equal "Riemann curvature" R_#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]_#_#)+assertEqual "Metric tensor"+  g_#_#+  [| [| r^2, 0 |], [| 0, r^2 * (sin θ)^2 |] |]_#_#+assertEqual "Metric tensor"+  g~#~#+  [| [| 1 / r^2, 0 |], [| 0, 1 / (r^2 * (sin θ)^2) |] |]~#~# -;;-;; Ricci curvature-;;+-- Christoffel symbols+Γ_i_j_k := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i) -(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))+assertEqual "Christoffel symbols of the first kind"+  Γ_1_#_#+  [| [| 0, 0 |], [| 0, -1 * r^2 * (sin θ) * (cos θ) |] |]_#_#+assertEqual "Christoffel symbols of the first kind"+  Γ_2_#_#+  [| [| 0, r^2 * (sin θ) * (cos θ) |], [| r^2 * (sin θ) * (cos θ), 0 |] |]_#_# -(assert-equal "Ricci curvature" Ric_#_# [| [| 1 0 |] [| 0 (sin θ)^2 |] |]_#_#)+Γ~i_j_k := withSymbols [m]+  g~i~m . Γ_m_j_k -;;-;; Scalar curvature-;;+assertEqual "Christoffel symbols of the second kind"+  Γ~1_#_#+  [| [| 0, 0 |], [| 0, -1 * sin θ * cos θ |] |]_#_#+assertEqual "Christoffel symbols of the second kind"+  Γ~2_#_#+  [| [| 0, (cos θ) / (sin θ) |], [| (cos θ) / (sin θ), 0 |] |]_#_# -(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))+-- Riemann curvature+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 -(assert-equal "Scalar curvature" scalar-curvature (/ 2 r^2))+assertEqual "riemann curvature"+  R~#_#_1_1+  [| [| 0, 0 |], [| 0, 0 |] |]~#_#+assertEqual "riemann curvature"+  R~#_#_1_2+  [| [| 0, (sin θ)^2 |], [| -1, 0 |] |]~#_#+assertEqual "riemann curvature"+  R~#_#_2_1+  [| [| 0, -1 * (sin θ)^2 |], [| 1, 0 |] |]~#_#+assertEqual "riemann curvature"+  R~#_#_2_2+  [| [| 0, 0 |], [| 0, 0 |] |]~#_# -;;-;; Covariant derivative of Riemann curvature tensor-;;+-- Ricci curvature+Ric_i_j := withSymbols [m]+  sum (contract R~m_i_m_j) -(define $∇R_____-  (with-symbols {i j k l m n}-    (- (∂/∂ R_i_j_k_l x~m)-       (. Γ~n_m_i R_n_j_k_l)-       (. Γ~n_m_j R_i_n_k_l)-       (. Γ~n_m_k R_i_j_n_l)-       (. Γ~n_m_l R_i_j_k_n))))+-- Scalar curvature+scalarCurvature := withSymbols [i, j]+  g~i~j . Ric_i_j -(assert-equal "Covariant derivative of Riemann curvature tensor"-  ∇R_#_#_#_#_#-  (tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#_#)+assertEqual "scalar curvature"+  scalarCurvature+  (2 / r^2)
− sample/math/geometry/riemann-curvature-tensor-of-S2xS3-conformal-fast.egi 
@@ -1,78 +0,0 @@-;;-;; Parameters-;;--(define $x [| φ θ ψ y α |])--;;-;; Riemann metric of S2 x S3-;;--(define $g__-  (* (a φ θ ψ y α)^2-     [|[| (/ (+ (* 3 '(+ 1 (* -1 y))^2 (sin θ)^2 '(+ a (* -1 y^2))) (* 2 '(+ a (* -3 y^2) (* 2 y^3)) (cos θ)^2 '(+ 1 (* -1 y))) (* '(+ a (* -2 y) y^2)^2 (cos θ)^2)) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (+ (* -2 '(+ a (* -3 y^2) (* 2 y^3)) (cos θ) '(+ 1 (* -1 y))) (* -1 '(+ a (* -2 y) y^2)^2 (cos θ))) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (* -1 '(+ a (* -2 y) y^2) (cos θ)) (* 3 '(+ 1 (* -1 y)))) |]-       [| 0 (/ '(+ 1 (* -1 y)) 6) 0 0 0 |]-       [| (/ (+ (* -2 '(+ a (* -3 y^2) (* 2 y^3)) (cos θ) '(+ 1 (* -1 y))) (* -1 '(+ a (* -2 y) y^2)^2 (cos θ))) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (+ (* 2 '(+ a (* -3 y^2) (* 2 y^3)) '(+ 1 (* -1 y))) '(+ a (* -2 y) y^2)^2) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (* 1 '(+ a (* -2 y) y^2)) (* 3 '(+ 1 (* -1 y)))) |]-       [| 0 0 0 (/ '(+ 1 (* -1 y)) (* 2 '(+ a (* -3 y^2) (* 2 y^3)))) 0 |]-       [| (/ (* -1 '(+ a (* -2 y) y^2) (cos θ)) (* 3 '(+ 1 (* -1 y)))) 0 (/ (* 1 '(+ a (* -2 y) y^2)) (* 3 '(+ 1 (* -1 y)))) 0 (/ (* 2 '(+ a (* -1 y^2))) '(+ 1 (* -1 y))) |]-       |]_#_#))--(define $g~~ (M.inverse g_#_#))-g~#~#--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))-Ric_#_#--;;-;; Wodzicki-Chern-Simons class-;;--(define $ret (let {[[$es $os] (even-and-odd-permutations 5)]}-               (- (sum' (map (lambda [$σ] (debug (.' R~u_5_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4)))) es))-                  (sum' (map (lambda [$σ] (debug (.' R~u_5_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4)))) os)))))--ret--(define $ret2 (/ (expand-all' (numerator ret)) (denominator ret)))--ret2--(define $ret3 (/ (2#%1 (P./ (numerator ret2) (* (+ 1 (* -1 y))^3 (+ a (* -1 y^2))^5) y))-                 (/ (denominator ret2) (* '(+ 1 (* -1 y))^3 '(+ a (* -1 y^2))^5))))--ret3
− sample/math/geometry/riemann-curvature-tensor-of-S2xS3-fast.egi 
@@ -1,80 +0,0 @@-;;-;; Parameters-;;--(define $x [| φ θ ψ y α |])--;;-;; Riemann metric of S2 x S3-;;--(define $g__-  [|[| (/ (+ (* 3 '(+ 1 (* -1 y))^2 (sin θ)^2 '(+ a (* -1 y^2))) (* 2 '(+ a (* -3 y^2) (* 2 y^3)) (cos θ)^2 '(+ 1 (* -1 y))) (* '(+ a (* -2 y) y^2)^2 (cos θ)^2)) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (+ (* -2 '(+ a (* -3 y^2) (* 2 y^3)) (cos θ) '(+ 1 (* -1 y))) (* -1 '(+ a (* -2 y) y^2)^2 (cos θ))) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (* -1 '(+ a (* -2 y) y^2) (cos θ)) (* 3 '(+ 1 (* -1 y)))) |]-    [| 0 (/ '(+ 1 (* -1 y)) 6) 0 0 0 |]-    [| (/ (+ (* -2 '(+ a (* -3 y^2) (* 2 y^3)) (cos θ) '(+ 1 (* -1 y))) (* -1 '(+ a (* -2 y) y^2)^2 (cos θ))) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (+ (* 2 '(+ a (* -3 y^2) (* 2 y^3)) '(+ 1 (* -1 y))) '(+ a (* -2 y) y^2)^2) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (* 1 '(+ a (* -2 y) y^2)) (* 3 '(+ 1 (* -1 y)))) |]-    [| 0 0 0 (/ '(+ 1 (* -1 y)) (* 2 '(+ a (* -3 y^2) (* 2 y^3)))) 0 |]-    [| (/ (* -1 '(+ a (* -2 y) y^2) (cos θ)) (* 3 '(+ 1 (* -1 y)))) 0 (/ (* 1 '(+ a (* -2 y) y^2)) (* 3 '(+ 1 (* -1 y)))) 0 (/ (* 2 '(+ a (* -1 y^2))) '(+ 1 (* -1 y))) |]-    |]_#_#)--(define $g~~ (M.inverse g_#_#))-g~#~#--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))-Ric_#_#--(expand-all' (with-symbols {i j} (-' Ric_i_j (*' 4 g_i_j))))-;[| [| 0 0 0 0 0 |] [| 0 0 0 0 0 |] [| 0 0 0 0 0 |] [| 0 0 0 0 0 |] [| 0 0 0 0 0 |] |]--;;-;; Wodzicki-Chern-Simons class-;;--(define $ret (let {[[$es $os] (even-and-odd-permutations 5)]}-               (- (sum' (map (lambda [$σ] (.' R~u_5_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4))) es))-                  (sum' (map (lambda [$σ] (.' R~u_5_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4))) os)))))--(define $ret2 (/ (expand-all' (numerator ret)) (denominator ret)))--ret2-;(/ (+ (* -128 a^6 y (sin θ)) (* 832 a^5 y^3 (sin θ)) (* -2240 a^4 y^5 (sin θ)) (* 3200 a^3 y^7 (sin θ)) (* -2560 a^2 y^9 (sin θ)) (* 1088 a y^11 (sin θ)) (* 384 a^6 y^2 (sin θ)) (* -1984 a^5 y^4 (sin θ)) (* 4160 a^4 y^6 (sin θ)) (* -4480 a^3 y^8 (sin θ)) (* 2560 a^2 y^10 (sin θ)) (* -704 a y^12 (sin θ)) (* -704 a^6 y^3 (sin θ)) (* 2560 a^5 y^5 (sin θ)) (* -4480 a^4 y^7 (sin θ)) (* 4160 a^3 y^9 (sin θ)) (* -1984 a^2 y^11 (sin θ)) (* 384 a y^13 (sin θ)) (* 1088 a^6 y^4 (sin θ)) (* -2560 a^5 y^6 (sin θ)) (* 3200 a^4 y^8 (sin θ)) (* -2240 a^3 y^10 (sin θ)) (* 832 a^2 y^12 (sin θ)) (* -128 a y^14 (sin θ)) (* -960 a^6 y^5 (sin θ)) (* 1920 a^5 y^7 (sin θ)) (* -1920 a^4 y^9 (sin θ)) (* 960 a^3 y^11 (sin θ)) (* -192 a^2 y^13 (sin θ)) (* 320 a^6 y^6 (sin θ)) (* -640 a^5 y^8 (sin θ)) (* 640 a^4 y^10 (sin θ)) (* -320 a^3 y^12 (sin θ)) (* 64 a^2 y^14 (sin θ)) (* 64 y^14 (sin θ)) (* 64 a^7 y (sin θ)) (* -192 a^7 y^2 (sin θ)) (* 192 a^7 y^3 (sin θ)) (* -64 a^7 y^4 (sin θ)) (* -192 a^5 (sin θ) y^2) (* 960 a^4 (sin θ) y^4) (* -1920 a^3 (sin θ) y^6) (* 1920 a^2 y^8 (sin θ)) (* -960 a y^10 (sin θ)) (* -320 y^3 a^4 (sin θ)) (* 640 y^5 a^3 (sin θ)) (* -640 y^7 a^2 (sin θ)) (* 320 y^9 a (sin θ)) (* -64 y^11 (sin θ)) (* 192 y^12 (sin θ)) (* 64 a^5 y (sin θ)) (* -192 y^13 (sin θ))) (* 3 '(+ 1 (* -1 y))^8 '(+ a (* -1 y^2))^5))--(define $ret3 (/ (2#%1 (P./ (numerator ret2) (* (+ 1 (* -1 y))^3 (+ a (* -1 y^2))^5) y))-                 (/ (denominator ret2) (* '(+ 1 (* -1 y))^3 '(+ a (* -1 y^2))^5))))--ret3-;(/ (+ (* 128 a (sin θ) y) (* -64 a^2 (sin θ) y) (* -64 (sin θ) y)) (* 3 '(+ 1 (* -1 y))^5))
− sample/math/geometry/riemann-curvature-tensor-of-S2xS3-integral.egi 
@@ -1,57 +0,0 @@-(define $ret3 (/ (+ (* 8 a (sin θ) y) (* -4 a^2 (sin θ) y) (* -4 (sin θ) y)) (* 45 '(+ 1 (* -1 y))^5)))--(define $ret4 (- (let {[$θ π]} (/ (+ (* 8 a (sin θ) y) (* -4 a^2 (sin θ) y) (* -4 (sin θ) y)) (* 45 '(+ 1 (* -1 y))^5)))-                 (let {[$θ 0]} (/ (+ (* 8 a (sin θ) y) (* -4 a^2 (sin θ) y) (* -4 (sin θ) y)) (* 45 '(+ 1 (* -1 y))^5)))))--"ret4"-ret4-;(/ (+ (* 16 a y) (* -8 a^2 y) (* -8 y)) (* 45 '(+ 1 (* -1 y))^5))--(define $ret5 (d/d (/ (* 2 (+ 1 (* -1 a))^2 (- 1 (* 4 y))) (* 135 '(+ 1 (* -1 y))^4)) y))--"ret5"-ret5--(define $ret6 (/ (expand-all' (numerator ret5)) (denominator ret5)))--"ret6"-ret6--(define $ret7 (/ (* 2 (+ 1 (* -1 a))^2 (- 1 (* 4 y))) (* 135 '(+ 1 (* -1 y))^4)))--(define $y1 (* (/ 1 2) (+ 1 (* -1 λ) (* -1 (sqrt (- 1 (/ λ^2 3)))))))-(define $y2 (+ y1 λ))---(let {[$y y2]} ret7)-(let {[$y y1]} ret7)--(define $ret8 (- (let {[$y y2]} (/ (* 2 (+ 1 (* -1 a))^2 (- 1 (* 4 y))) (* 135 '(+ 1 (* -1 y))^4)))-                 (let {[$y y1]} (/ (* 2 (+ 1 (* -1 a))^2 (- 1 (* 4 y))) (* 135 '(+ 1 (* -1 y))^4)))))--"ret8"-ret8-;(/ (+ (* -6 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 λ '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 12 a '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 24 a λ '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -8 a (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -6 a^2 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 a^2 λ '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 4 a^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 6 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 λ '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 a '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 24 a λ '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 8 a (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 6 a^2 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 a^2 λ '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -4 a^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4)) (* 405 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4))--(define $ret9 (let {[$a (- (* 3 y1^2) (* 2 y2^3))]}-                (/ (+ (* -6 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 λ '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 12 a '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 24 a λ '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -8 a (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -6 a^2 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 a^2 λ '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 4 a^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 6 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 λ '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 a '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 24 a λ '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 8 a (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 6 a^2 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -12 a^2 λ '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -4 a^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4)) (* 405 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4))))--"ret9"-ret9-;(/ (+ (* -324 λ '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 54 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -108 λ (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 5742 λ^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -17793 λ^2 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 5544 λ^3 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 162 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -15390 λ^3 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 1548 λ^4 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 2808 λ^5 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 912 λ^6 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 360 λ^4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 96 λ^7 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -288 λ^5 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -32 λ^6 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -324 λ '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -54 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -108 λ (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -5742 λ^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 17793 λ^2 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 2520 λ^3 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -162 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -6966 λ^3 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -8028 λ^4 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 216 λ^5 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 816 λ^6 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 1368 λ^4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 96 λ^7 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 288 λ^5 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 32 λ^6 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4)) (* 21870 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4))--(define $ret10 (let {[$λ (/ (* 3 q) (* 2 p))]}-                 (/ (+ (* -324 λ '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 54 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -108 λ (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 5742 λ^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -17793 λ^2 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 5544 λ^3 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 162 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -15390 λ^3 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 1548 λ^4 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 2808 λ^5 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 912 λ^6 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 360 λ^4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 96 λ^7 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -288 λ^5 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -32 λ^6 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -324 λ '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -54 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -108 λ (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -5742 λ^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 17793 λ^2 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 2520 λ^3 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -162 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -6966 λ^3 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -8028 λ^4 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 216 λ^5 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 816 λ^6 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 1368 λ^4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 96 λ^7 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 288 λ^5 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 32 λ^6 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4)) (* 21870 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4))))--"ret10"-ret10--(define $ret11 (let* {[$p 7]-                      [$q 3]-                      [$λ (/ (* 3 q) (* 2 p))]}-                 (* (/ (+ (* -324 λ '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 54 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -108 λ (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 5742 λ^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -17793 λ^2 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 5544 λ^3 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 162 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -15390 λ^3 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 1548 λ^4 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 2808 λ^5 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 912 λ^6 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 360 λ^4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 96 λ^7 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -288 λ^5 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -32 λ^6 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -324 λ '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -54 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -108 λ (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -5742 λ^2 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 17793 λ^2 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 2520 λ^3 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -162 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -6966 λ^3 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* -8028 λ^4 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 216 λ^5 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 816 λ^6 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 1368 λ^4 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 96 λ^7 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 288 λ^5 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4) (* 32 λ^6 (sqrt (+ 9 (* -3 λ^2))) '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4)) (* 21870 '(/ (+ 3 (* -3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4 '(/ (+ 3 (* 3 λ) (sqrt (+ 9 (* -3 λ^2)))) 6)^4))-                    (* 2^4 π^4 (/ q (+ (* 3 q^2) (* -2 p^2) (* p (sqrt (+ (* 4 p^2) (* -3 q^2))))))))))---(expand-all ret11)-;(/ (* -1849 π^4) 22050)
− sample/math/geometry/riemann-curvature-tensor-of-S2xS3.egi 
@@ -1,81 +0,0 @@-;;-;; Parameters-;;--(define $x [| φ θ ψ y α |])--;;-;; Riemann metric of S2 x S3-;;--(define $g__-  [|[| (/ (+ (* 3 '(+ 1 (* -1 y))^2 (sin θ)^2 '(+ a (* -1 y^2))) (* 2 '(+ a (* -3 y^2) (* 2 y^3)) (cos θ)^2 '(+ 1 (* -1 y))) (* '(+ a (* -2 y) y^2)^2 (cos θ)^2)) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (+ (* -2 '(+ a (* -3 y^2) (* 2 y^3)) (cos θ) '(+ 1 (* -1 y))) (* -1 '(+ a (* -2 y) y^2)^2 (cos θ))) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (* -1 '(+ a (* -2 y) y^2) (cos θ)) (* 3 '(+ 1 (* -1 y)))) |]-    [| 0 (/ '(+ 1 (* -1 y)) 6) 0 0 0 |]-    [| (/ (+ (* -2 '(+ a (* -3 y^2) (* 2 y^3)) (cos θ) '(+ 1 (* -1 y))) (* -1 '(+ a (* -2 y) y^2)^2 (cos θ))) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (+ (* 2 '(+ a (* -3 y^2) (* 2 y^3)) '(+ 1 (* -1 y))) '(+ a (* -2 y) y^2)^2) (* 18 '(+ a (* -1 y^2)) '(+ 1 (* -1 y)))) 0 (/ (* 1 '(+ a (* -2 y) y^2)) (* 3 '(+ 1 (* -1 y)))) |]-    [| 0 0 0 (/ '(+ 1 (* -1 y)) (* 2 '(+ a (* -3 y^2) (* 2 y^3)))) 0 |]-    [| (/ (* -1 '(+ a (* -2 y) y^2) (cos θ)) (* 3 '(+ 1 (* -1 y)))) 0 (/ (* 1 '(+ a (* -2 y) y^2)) (* 3 '(+ 1 (* -1 y)))) 0 (/ (* 2 '(+ a (* -1 y^2))) '(+ 1 (* -1 y))) |]-    |]_#_#)--(define $g~~ (M.inverse g_#_#))-g~#~#--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))-Ric_#_#--(expand-all' (with-symbols {i j} (-' Ric_i_j (*' 4 g_i_j))))-;[| [| 0 0 0 0 0 |] [| 0 0 0 0 0 |] [| 0 0 0 0 0 |] [| 0 0 0 0 0 |] [| 0 0 0 0 0 |] |]--;;-;; Wodzicki-Chern-Simons class-;;--(define $ret (let {[[$es $os] (even-and-odd-permutations 5)]}-               (/ (- (sum (map (lambda [$σ] (. R~u_5_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4))) es))-                     (sum (map (lambda [$σ] (. R~u_5_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4))) os)))-                  (* 2 (fact 5)))))--(define $ret2 (/ (expand-all' (numerator ret)) (denominator ret)))--ret2-;--(define $ret3 (/ (2#%1 (P./ (numerator ret2) (* (+ 1 (* -1 y))^3 (+ a (* -1 y^2))^5) y))-                 (/ (denominator ret2) (* '(+ 1 (* -1 y))^3 '(+ a (* -1 y^2))^5))))--ret3-;(/ (+ (* 8 a (sin θ) y) (* -4 a^2 (sin θ) y) (* -4 (sin θ) y)) (* 45 '(+ 1 (* -1 y))^5))
− sample/math/geometry/riemann-curvature-tensor-of-S3.egi 
@@ -1,108 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|θ φ ψ|])--(define $X [|(* r (cos θ))-             (* r (sin θ) (cos φ))-             (* r (sin θ) (sin φ) (cos ψ))-             (* r (sin θ) (sin φ) (sin ψ))-             |])--;;-;; Local basis-;;--(define $e ((flip ∂/∂) x~# X_#))-e-;[|[| (* -1 r (sin θ)) (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ) (cos ψ)) (* r (cos θ) (sin φ) (sin ψ)) |]-;  [| 0 (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ) (cos ψ)) (* r (sin θ) (cos φ) (sin ψ)) |]-;  [| 0 0 (* -1 r (sin θ) (sin φ) (sin ψ)) (* r (sin θ) (sin φ) (cos ψ)) |]|]--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {3 3}))-(define $g~~ (M.inverse g_#_#))-g_#_#;[| [| r^2 0 0 |] [| 0 (* r^2 (sin θ)^2) 0 |] [| 0 0 (* r^2 (sin θ)^2 (sin φ)^2) |] |]_#_#-g~#~#;[| [| (/ 1 r^2) 0 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) 0 |] [| 0 0 (/ 1 (* r^2 (sin θ)^2 (sin φ)^2)) |] |]~#~#--(with-symbols {i j k} (. g~i~j g_j_k));[| [| 1 0 0 |] [| 0 1 0 |] [| 0 0 1 |] |]--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_k x~l)-        (∂/∂ g_j_l x~k)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_1_#_#;[| [| 0 0 0 |] [| 0 (* -1 r^2 (sin θ) (cos θ)) 0 |] [| 0 0 (* -1 r^2 (sin θ) (cos θ) (sin φ)^2) |] |]_#_#-Γ_2_#_#;[| [| 0 (* r^2 (sin θ) (cos θ)) 0 |] [| (* r^2 (sin θ) (cos θ)) 0 0 |] [| 0 0 (* -1 r^2 (sin θ)^2 (sin φ) (cos φ)) |] |]_#_#-Γ_3_#_#;[| [| 0 0 (* r^2 (sin θ) (cos θ) (sin φ)^2) |] [| 0 0 (* r^2 (sin θ)^2 (sin φ) (cos φ)) |] [| (* r^2 (sin θ) (cos θ) (sin φ)^2) (* r^2 (sin θ)^2 (sin φ) (cos φ)) 0 |] |]_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~1_#_#;[| [| 0 0 0 |] [| 0 (* -1 (sin θ) (cos θ)) 0 |] [| 0 0 (* -1 (sin θ) (cos θ) (sin φ)^2) |] |]_#_#-Γ~2_#_#;[| [| 0 (/ (cos θ) (sin θ)) 0 |] [| (/ (cos θ) (sin θ)) 0 0 |] [| 0 0 (* -1 (sin φ) (cos φ)) |] |]_#_#-Γ~3_#_#;[| [| 0 0 (/ (cos θ) (sin θ)) |] [| 0 0 (/ (cos φ) (sin φ)) |] [| (/ (cos θ) (sin θ)) (/ (cos φ) (sin φ)) 0 |] |]_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_1_1;[| [| 0 0 0 |] [| 0 0 0 |] [| 0 0 0 |] |]~#_#-R~#_#_1_2;[| [| 0 (sin θ)^2 0 |] [| -1 0 0 |] [| 0 0 0 |] |]~#_#-R~#_#_1_3;[| [| 0 0 (* (sin θ)^2 (sin φ)^2) |] [| 0 0 0 |] [| -1 0 0 |] |]~#_#-R~#_#_2_1;[| [| 0 (* -1 (sin θ)^2) 0 |] [| 1 0 0 |] [| 0 0 0 |] |]~#_#-R~#_#_2_2;[| [| 0 0 0 |] [| 0 0 0 |] [| 0 0 0 |] |]~#_#-R~#_#_2_3;[| [| 0 0 0 |] [| 0 0 (* (sin θ)^2 (sin φ)^2) |] [| 0 (* -1 (sin θ)^2) 0 |] |]~#_#-R~#_#_3_1;[| [| 0 0 (* -1 (sin θ)^2 (sin φ)^2) |] [| 0 0 0 |] [| 1 0 0 |] |]~#_#-R~#_#_3_2;[| [| 0 0 0 |] [| 0 0 (* -1 (sin θ)^2 (sin φ)^2) |] [| 0 (sin θ)^2 0 |] |]~#_#-R~#_#_3_3;[| [| 0 0 0 |] [| 0 0 0 |] [| 0 0 0 |] |]~#_#--(define $R____ (with-symbols {i} (. g_i_# R~i_#_#_#)))--R_#_#_#_#;(tensor {3 3 3 3} {0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^2) 0 (* -1 r^2 (sin θ)^2) 0 0 0 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2) 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2) 0 0 0 (* -1 r^2 (sin θ)^2) 0 (* r^2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^4 (sin φ)^2) 0 (* -1 r^2 (sin θ)^4 (sin φ)^2) 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2) 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^2) 0 (* r^2 (sin θ)^4 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))--Ric_#_#;[| [| 2 0 0 |] [| 0 (* 2 (sin θ)^2) 0 |] [| 0 0 (* 2 (sin θ)^2 (sin φ)^2) |] |]_#_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature;(/ 6 r^2)--;;-;; Conformal curvature tensor-;;--(define $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)))-     (* (/ scalar-curvature 2) (- (. g_i_l g_k_m) (. g_i_m g_k_l)))))--C_#_#_#_#-;(tensor {3 3 3 3} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#
− sample/math/geometry/riemann-curvature-tensor-of-S4.egi 
@@ -1,145 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|θ φ ψ η|])--(define $X [|(* r (cos θ))-             (* r (sin θ) (cos φ))-             (* r (sin θ) (sin φ) (cos ψ))-             (* r (sin θ) (sin φ) (sin ψ) (cos η))-             (* r (sin θ) (sin φ) (sin ψ) (sin η))-             |])--;;-;; Local basis-;;--(define $e ((flip ∂/∂) x~# X_#))-e-;[|[| (* -1 r (sin θ)) (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ) (cos ψ)) (* r (cos θ) (sin φ) (sin ψ) (cos η)) (* r (cos θ) (sin φ) (sin ψ) (sin η)) |]-;  [| 0 (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ) (cos ψ)) (* r (sin θ) (cos φ) (sin ψ) (cos η)) (* r (sin θ) (cos φ) (sin ψ) (sin η)) |]-;  [| 0 0 (* -1 r (sin θ) (sin φ) (sin ψ)) (* r (sin θ) (sin φ) (cos ψ) (cos η)) (* r (sin θ) (sin φ) (cos ψ) (sin η)) |]-;  [| 0 0 0 (* -1 r (sin θ) (sin φ) (sin ψ) (sin η)) (* r (sin θ) (sin φ) (sin ψ) (cos η)) |] |]_#~#--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {4 4}))-(define $g~~ (M.inverse g_#_#))-g_#_#;[| [| r^2 0 0 0 |] [| 0 (* r^2 (sin θ)^2) 0 0 |] [| 0 0 (* r^2 (sin θ)^2 (sin φ)^2) 0 |] [| 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) |] |]_#_#-g~#~#;[| [| (/ 1 r^2) 0 0 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) 0 0 |] [| 0 0 (/ 1 (* r^2 (sin θ)^2 (sin φ)^2)) 0 |] [| 0 0 0 (/ 1 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2)) |] |]~#~#--(with-symbols {i j k} (. g~i~j g_j_k))-;[| [| 1 0 0 0 |] [| 0 1 0 0 |] [| 0 0 1 0 |] [| 0 0 0 1 |] |]--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_k x~l)-        (∂/∂ g_j_l x~k)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_1_#_#;[| [| 0 0 0 0 |] [| 0 (/ (* -1 r^2 (sin (* 2 θ))) 2) 0 0 |] [| 0 0 (/ (* -1 r^2 (sin (* 2 θ)) (sin φ)^2) 2) 0 |] [| 0 0 0 (/ (* -1 r^2 (sin (* 2 θ)) (sin φ)^2 (sin ψ)^2) 2) |] |]_#_#-Γ_2_#_#;[| [| 0 (/ (* r^2 (sin (* 2 θ))) 2) 0 0 |] [| (/ (* r^2 (sin (* 2 θ))) 2) 0 0 0 |] [| 0 0 (/ (* -1 r^2 (sin θ)^2 (sin (* 2 φ))) 2) 0 |] [| 0 0 0 (/ (* -1 r^2 (sin θ)^2 (sin (* 2 φ)) (sin ψ)^2) 2) |] |]_#_#-Γ_3_#_#;[| [| 0 0 (/ (* r^2 (sin (* 2 θ)) (sin φ)^2) 2) 0 |] [| 0 0 (/ (* r^2 (sin θ)^2 (sin (* 2 φ))) 2) 0 |] [| (/ (* r^2 (sin (* 2 θ)) (sin φ)^2) 2) (/ (* r^2 (sin θ)^2 (sin (* 2 φ))) 2) 0 0 |] [| 0 0 0 (/ (* -1 r^2 (sin θ)^2 (sin φ)^2 (sin (* 2 ψ))) 2) |] |]_#_#-Γ_4_#_#;[| [| 0 0 0 (/ (* r^2 (sin (* 2 θ)) (sin φ)^2 (sin ψ)^2) 2) |] [| 0 0 0 (/ (* r^2 (sin θ)^2 (sin (* 2 φ)) (sin ψ)^2) 2) |] [| 0 0 0 (/ (* r^2 (sin θ)^2 (sin φ)^2 (sin (* 2 ψ))) 2) |] [| (/ (* r^2 (sin (* 2 θ)) (sin φ)^2 (sin ψ)^2) 2) (/ (* r^2 (sin θ)^2 (sin (* 2 φ)) (sin ψ)^2) 2) (/ (* r^2 (sin θ)^2 (sin φ)^2 (sin (* 2 ψ))) 2) 0 |] |]_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~1_#_#;[| [| 0 0 0 0 |] [| 0 (/ (* -1 (sin (* 2 θ))) 2) 0 0 |] [| 0 0 (/ (* -1 (sin (* 2 θ)) (sin φ)^2) 2) 0 |] [| 0 0 0 (/ (* -1 (sin (* 2 θ)) (sin φ)^2 (sin ψ)^2) 2) |] |]_#_#-Γ~2_#_#;[| [| 0 (/ (cos θ) (sin θ)) 0 0 |] [| (/ (cos θ) (sin θ)) 0 0 0 |] [| 0 0 (/ (* -1 (sin (* 2 φ))) 2) 0 |] [| 0 0 0 (/ (* -1 (sin (* 2 φ)) (sin ψ)^2) 2) |] |]_#_#-Γ~3_#_#;[| [| 0 0 (/ (cos θ) (sin θ)) 0 |] [| 0 0 (/ (cos φ) (sin φ)) 0 |] [| (/ (cos θ) (sin θ)) (/ (cos φ) (sin φ)) 0 0 |] [| 0 0 0 (/ (* -1 (sin (* 2 ψ))) 2) |] |]_#_#-Γ~4_#_#;[| [| 0 0 0 (/ (cos θ) (sin θ)) |] [| 0 0 0 (/ (cos φ) (sin φ)) |] [| 0 0 0 (/ (cos ψ) (sin ψ)) |] [| (/ (cos θ) (sin θ)) (/ (cos φ) (sin φ)) (/ (cos ψ) (sin ψ)) 0 |] |]_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_1_1;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_1_2;[| [| 0 (* -1 (sin θ)^2) 0 0 |] [| 1 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_1_3;[| [| 0 0 (* -1 (sin θ)^2 (sin φ)^2) 0 |] [| 0 0 0 0 |] [| 1 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_1_4;[| [| 0 0 0 (* -1 (sin θ)^2 (sin φ)^2 (sin ψ)^2) |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 1 0 0 0 |] |]~#_#-R~#_#_2_1;[| [| 0 (sin θ)^2 0 0 |] [| -1 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_2_2;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_2_3;[| [| 0 0 0 0 |] [| 0 0 (+ (* -1 (sin φ)^2) (* (cos θ)^2 (sin φ)^2)) 0 |] [| 0 (sin θ)^2 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_2_4;[| [| 0 0 0 0 |] [| 0 0 0 (+ (* -1 (sin φ)^2 (sin ψ)^2) (* (cos θ)^2 (sin φ)^2 (sin ψ)^2)) |] [| 0 0 0 0 |] [| 0 (sin θ)^2 0 0 |] |]~#_#-R~#_#_3_1;[| [| 0 0 (* (sin θ)^2 (sin φ)^2) 0 |] [| 0 0 0 0 |] [| -1 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_3_2;[| [| 0 0 0 0 |] [| 0 0 (+ (sin φ)^2 (* -1 (cos θ)^2 (sin φ)^2)) 0 |] [| 0 (* -1 (sin θ)^2) 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_3_3;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_3_4;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 (+ (* -1 (sin ψ)^2) (* (cos θ)^2 (sin φ)^2 (sin ψ)^2) (* (cos φ)^2 (sin ψ)^2)) |] [| 0 0 (* (sin θ)^2 (sin φ)^2) 0 |] |]~#_#-R~#_#_4_1;[| [| 0 0 0 (* (sin θ)^2 (sin φ)^2 (sin ψ)^2) |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| -1 0 0 0 |] |]~#_#-R~#_#_4_2;[| [| 0 0 0 0 |] [| 0 0 0 (+ (* (sin φ)^2 (sin ψ)^2) (* -1 (cos θ)^2 (sin φ)^2 (sin ψ)^2)) |] [| 0 0 0 0 |] [| 0 (* -1 (sin θ)^2) 0 0 |] |]~#_#-R~#_#_4_3;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 (+ (sin ψ)^2 (* -1 (cos θ)^2 (sin φ)^2 (sin ψ)^2) (* -1 (cos φ)^2 (sin ψ)^2)) |] [| 0 0 (* -1 (sin θ)^2 (sin φ)^2) 0 |] |]~#_#-R~#_#_4_4;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#--(define $R____ (with-symbols {i} (. g_i_# R~i_#_#_#)))--R_#_#_#_#;(tensor {4 4 4 4} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 r^2 (sin θ)^2) 0 0 (* r^2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 (* r^2 (sin θ)^2) 0 0 (* -1 r^2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (+ (* (cos θ)^2 (sin θ)^2 r^2 (sin φ)^2) (* -1 r^2 (sin θ)^2 (sin φ)^2)) 0 0 (+ (* -1 (cos θ)^2 (sin θ)^2 r^2 (sin φ)^2) (* r^2 (sin θ)^2 (sin φ)^2)) 0 0 0 0 0 0 0 0 0 0 0 0 0 (+ (* (cos θ)^2 (sin θ)^2 r^2 (sin φ)^2 (sin ψ)^2) (* -1 r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2)) 0 0 0 0 0 (+ (* -1 (cos θ)^2 (sin θ)^2 r^2 (sin φ)^2 (sin ψ)^2) (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2)) 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^4 (sin φ)^2) 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (+ (* (cos θ)^2 (sin θ)^2 r^2 (sin φ)^4 (sin ψ)^2) (* -1 r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) (* r^2 (sin θ)^2 (sin φ)^2 (cos φ)^2 (sin ψ)^2)) 0 0 (+ (* -1 (cos θ)^2 (sin θ)^2 r^2 (sin φ)^4 (sin ψ)^2) (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) (* -1 r^2 (sin θ)^2 (sin φ)^2 (cos φ)^2 (sin ψ)^2)) 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^4 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^4 (sin φ)^4 (sin ψ)^2) 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^4 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))--Ric_#_#;[| [| 3 0 0 0 |] [| 0 (* 3 (sin θ)^2) 0 0 |] [| 0 0 (* 3 (sin θ)^2 (sin φ)^2) 0 |] [| 0 0 0 (* 3 (sin θ)^2 (sin φ)^2 (sin ψ)^2) |] |]_#_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature;(/ 12 r^2)--;;-;; Covariant derivative of Ricci curvature-;;--(define $∇Ric___-  (with-symbols {i j k l m n}-    (- (∂/∂ Ric_i_j x~m)-       (. Γ~n_m_i Ric_n_j)-       (. Γ~n_m_j Ric_i_n)-       )))--∇Ric_#_#_#-;(tensor {4 4 4} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#--;;-;; Conformal curvature tensor-;;--(define $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)))-     (* (/ scalar-curvature 2) (- (. g_i_l g_k_m) (. g_i_m g_k_l)))))--C_#_#_#_#-;;(tensor {4 4 4 4} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^2) 0 0 (* -1 r^2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 (* -1 r^2 (sin θ)^2) 0 0 (* r^2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^4 (sin φ)^2) 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^4 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^2 (sin ψ)^2) 0 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^2) 0 0 (* r^2 (sin θ)^4 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^4 (sin φ)^4 (sin ψ)^2) 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^4 (sin ψ)^2) 0 0 0 0 (* -1 r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 (* r^2 (sin θ)^4 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 r^2 (sin θ)^4 (sin φ)^4 (sin ψ)^2) 0 0 (* r^2 (sin θ)^4 (sin φ)^4 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#--;;-;; Pontryagin Class-;;--(define $P-  (let {[[$es $os] (even-and-odd-permutations 4)]}-    (- (sum (map (lambda [$σ] (. R~s_t_(σ 2)_(σ 1) R~t_s_(σ 4)_(σ 3))) es))-       (sum (map (lambda [$σ] (. R~s_t_(σ 2)_(σ 1) R~t_s_(σ 4)_(σ 3))) os)))))--P;0
− sample/math/geometry/riemann-curvature-tensor-of-S5-conformal-weyl.egi 
@@ -1,126 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|θ φ ψ η δ|])--(define $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-;;--(define $e ((flip ∂/∂) x~# X_#))-e-;[|[| (* -1 r (sin θ)) (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ) (cos ψ)) (* r (cos θ) (sin φ) (sin ψ) (cos η)) (* r (cos θ) (sin φ) (sin ψ) (sin η) (cos δ)) (* r (cos θ) (sin φ) (sin ψ) (sin η) (sin δ)) |]-;  [| 0 (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ) (cos ψ)) (* r (sin θ) (cos φ) (sin ψ) (cos η)) (* r (sin θ) (cos φ) (sin ψ) (sin η) (cos δ)) (* r (sin θ) (cos φ) (sin ψ) (sin η) (sin δ)) |]-;  [| 0 0 (* -1 r (sin θ) (sin φ) (sin ψ)) (* r (sin θ) (sin φ) (cos ψ) (cos η)) (* r (sin θ) (sin φ) (cos ψ) (sin η) (cos δ)) (* r (sin θ) (sin φ) (cos ψ) (sin η) (sin δ)) |]-;  [| 0 0 0 (* -1 r (sin θ) (sin φ) (sin ψ) (sin η)) (* r (sin θ) (sin φ) (sin ψ) (cos η) (cos δ)) (* r (sin θ) (sin φ) (sin ψ) (cos η) (sin δ)) |]-;  [| 0 0 0 0 (* -1 r (sin θ) (sin φ) (sin ψ) (sin η) (sin δ)) (* r (sin θ) (sin φ) (sin ψ) (sin η) (cos δ)) |] |]--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(* (a θ φ ψ η δ)^2 (V.* e_%1 e_%2)) {5 5}))-(define $g~~ (M.inverse g_#_#))-g_#_#-g~#~#--(with-symbols {i j k} (. g~i~j g_j_k))-;--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#--(define $R____ (with-symbols {i} (. g_i_# R~i_#_#_#)))--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))--Ric_#_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature-;(/ (+ (* 20 (a θ φ ψ η δ)^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -8 (a|1|1 θ φ ψ η δ) (a θ φ ψ η δ) (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -8 (a|2|2 θ φ ψ η δ) (a θ φ ψ η δ) (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -8 (a|3|3 θ φ ψ η δ) (a θ φ ψ η δ) (sin ψ)^2 (sin η)^2)-;      (* -8 (a|4|4 θ φ ψ η δ) (a θ φ ψ η δ) (sin η)^2)-;      (* -8 (a|5|5 θ φ ψ η δ) (a θ φ ψ η δ))-;      (* -4 (a|1 θ φ ψ η δ)^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -4 (a|2 θ φ ψ η δ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -4 (a|3 θ φ ψ η δ)^2 (sin ψ)^2 (sin η)^2)-;      (* -4 (a|4 θ φ ψ η δ)^2 (sin η)^2)-;      (* -4 (a|5 θ φ ψ η δ)^2)-;      (* -32 (a|1 θ φ ψ η δ) (a θ φ ψ η δ) (cos θ) (sin θ) (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -24 (a|2 θ φ ψ η δ) (a θ φ ψ η δ) (cos φ) (sin φ) (sin ψ)^2 (sin η)^2)-;      (* -16 (a|3 θ φ ψ η δ) (a θ φ ψ η δ) (cos ψ) (sin ψ) (sin η)^2)-;      (* -8 (a|4 θ φ ψ η δ) (a θ φ ψ η δ) (cos η) (sin η))-;      )-;   (* (a θ φ ψ η δ)^4 r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2))--;;-;; Weyl curvature tensor-;;-(define $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)))-     (* (/ scalar-curvature 2) (- (. g_i_l g_k_m) (. g_i_m g_k_l)))))--C_#_#_#_#--(define $C~___ (with-symbols {i} (. g~i~# C_i_#_#_#)))-C~#_#_#_#--;;-;; Wodzicki-Chern-Simons class-;;--(let {[[$es $os] (even-and-odd-permutations 5)]}-  (- (sum' (map (lambda [$σ] (.' C~u_1_s_(σ 1) C~s_t_(σ 3)_(σ 2) C~t_u_(σ 5)_(σ 4))) es))-     (sum' (map (lambda [$σ] (.' C~u_1_s_(σ 1) C~s_t_(σ 3)_(σ 2) C~t_u_(σ 5)_(σ 4))) os))))-;0
− sample/math/geometry/riemann-curvature-tensor-of-S5-conformal.egi 
@@ -1,110 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|θ φ ψ η δ|])--(define $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-;;--(define $e ((flip ∂/∂) x~# X_#))-e-;[|[| (* -1 r (sin θ)) (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ) (cos ψ)) (* r (cos θ) (sin φ) (sin ψ) (cos η)) (* r (cos θ) (sin φ) (sin ψ) (sin η) (cos δ)) (* r (cos θ) (sin φ) (sin ψ) (sin η) (sin δ)) |]-7;  [| 0 (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ) (cos ψ)) (* r (sin θ) (cos φ) (sin ψ) (cos η)) (* r (sin θ) (cos φ) (sin ψ) (sin η) (cos δ)) (* r (sin θ) (cos φ) (sin ψ) (sin η) (sin δ)) |]-;  [| 0 0 (* -1 r (sin θ) (sin φ) (sin ψ)) (* r (sin θ) (sin φ) (cos ψ) (cos η)) (* r (sin θ) (sin φ) (cos ψ) (sin η) (cos δ)) (* r (sin θ) (sin φ) (cos ψ) (sin η) (sin δ)) |]-;  [| 0 0 0 (* -1 r (sin θ) (sin φ) (sin ψ) (sin η)) (* r (sin θ) (sin φ) (sin ψ) (cos η) (cos δ)) (* r (sin θ) (sin φ) (sin ψ) (cos η) (sin δ)) |]-;  [| 0 0 0 0 (* -1 r (sin θ) (sin φ) (sin ψ) (sin η) (sin δ)) (* r (sin θ) (sin φ) (sin ψ) (sin η) (cos δ)) |] |]--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(* (a θ φ ψ η δ)^2 (V.* e_%1 e_%2)) {5 5}))-(define $g~~ (M.inverse g_#_#))-g_#_#-g~#~#--(with-symbols {i j k} (. g~i~j g_j_k))-;--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))--Ric_#_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature-;(/ (+ (* 20 (a θ φ ψ η δ)^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -8 (a|1|1 θ φ ψ η δ) (a θ φ ψ η δ) (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -8 (a|2|2 θ φ ψ η δ) (a θ φ ψ η δ) (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -8 (a|3|3 θ φ ψ η δ) (a θ φ ψ η δ) (sin ψ)^2 (sin η)^2)-;      (* -8 (a|4|4 θ φ ψ η δ) (a θ φ ψ η δ) (sin η)^2)-;      (* -8 (a|5|5 θ φ ψ η δ) (a θ φ ψ η δ))-;      (* -4 (a|1 θ φ ψ η δ)^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -4 (a|2 θ φ ψ η δ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -4 (a|3 θ φ ψ η δ)^2 (sin ψ)^2 (sin η)^2)-;      (* -4 (a|4 θ φ ψ η δ)^2 (sin η)^2)-;      (* -4 (a|5 θ φ ψ η δ)^2)-;      (* -32 (a|1 θ φ ψ η δ) (a θ φ ψ η δ) (cos θ) (sin θ) (sin φ)^2 (sin ψ)^2 (sin η)^2)-;      (* -24 (a|2 θ φ ψ η δ) (a θ φ ψ η δ) (cos φ) (sin φ) (sin ψ)^2 (sin η)^2)-;      (* -16 (a|3 θ φ ψ η δ) (a θ φ ψ η δ) (cos ψ) (sin ψ) (sin η)^2)-;      (* -8 (a|4 θ φ ψ η δ) (a θ φ ψ η δ) (cos η) (sin η))-;      )-;   (* (a θ φ ψ η δ)^4 r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2))--;;-;; Wodzicki-Chern-Simons class-;;--(let {[[$es $os] (even-and-odd-permutations 5)]}-  (- (sum' (map (lambda [$σ] (debug (.' R~u_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4)))) es))-     (sum' (map (lambda [$σ] (debug (.' R~u_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4)))) os))))-;0
− sample/math/geometry/riemann-curvature-tensor-of-S5-weyl.egi 
@@ -1,113 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|θ φ ψ η ζ|])--(define $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-;;--(define $e ((flip ∂/∂) x~# X_#))-e-;[|[| (* -1 r (sin θ)) (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ) (cos ψ)) (* r (cos θ) (sin φ) (sin ψ) (cos η)) (* r (cos θ) (sin φ) (sin ψ) (sin η) (cos ζ)) (* r (cos θ) (sin φ) (sin ψ) (sin η) (sin ζ)) |]-;  [| 0 (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ) (cos ψ)) (* r (sin θ) (cos φ) (sin ψ) (cos η)) (* r (sin θ) (cos φ) (sin ψ) (sin η) (cos ζ)) (* r (sin θ) (cos φ) (sin ψ) (sin η) (sin ζ)) |]-;  [| 0 0 (* -1 r (sin θ) (sin φ) (sin ψ)) (* r (sin θ) (sin φ) (cos ψ) (cos η)) (* r (sin θ) (sin φ) (cos ψ) (sin η) (cos ζ)) (* r (sin θ) (sin φ) (cos ψ) (sin η) (sin ζ)) |]-;  [| 0 0 0 (* -1 r (sin θ) (sin φ) (sin ψ) (sin η)) (* r (sin θ) (sin φ) (sin ψ) (cos η) (cos ζ)) (* r (sin θ) (sin φ) (sin ψ) (cos η) (sin ζ)) |]-;  [| 0 0 0 0 (* -1 r (sin θ) (sin φ) (sin ψ) (sin η) (sin ζ)) (* r (sin θ) (sin φ) (sin ψ) (sin η) (cos ζ)) |] |]--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {5 5}))-(define $g~~ (M.inverse g_#_#))-g_#_#-g~#~#--(with-symbols {i j k} (. g~i~j g_j_k))-;[| [| 1 0 0 0 0 |] [| 0 1 0 0 0 |] [| 0 0 1 0 0 |] [| 0 0 0 1 0 |] [| 0 0 0 0 1 |] |]--;;-;; Christoffel symbols of the first kind-;;--(define $Γ___-  (with-symbols {j k l}-    (* (/ 1 2)-       (+ (∂/∂ g_j_l x~k)-          (∂/∂ g_j_k x~l)-          (* -1 (∂/∂ g_k_l x~j))))))--Γ_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__-  (with-symbols {i j k l}-    (. g~i~j Γ_j_k_l)))--Γ~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#-;(tensor {5 5 5 5} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2) 0 0 0 (sin θ)^2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 (* (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 (* (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 1 0 0 0 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2) 0 0 0 (* (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 (* (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 0 0 0 0 0 0 (* (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 1 0 0 0 0 0 0 0 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (sin θ)^2 0 0 0 (* -1 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 (* (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 0 0 (* (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (sin θ)^2 0 0 0 0 0 0 0 (* -1 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* (sin θ)^2 (sin φ)^2) 0 0 0 (* -1 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 (* (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 (sin θ)^2 0 0 0 0 0 0 0 0 0 0 0 (* -1 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 (* -1 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 (* -1 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )~#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i j k} (contract + R~i_j_k_i)))--Ric_#_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature--;;-;; Weyl curvature tensor-;;-(define $δ [| [| 1 0 0 0 0 |] [| 0 1 0 0 0 |] [| 0 0 1 0 0 |] [| 0 0 0 1 0 |] [| 0 0 0 0 1 |] |])-(define $Ric~_ (with-symbols {i k h} (. g~i~h Ric_k_h)))--(define $C~___-  (with-symbols {i j k l}-    (+ R~i_j_k_l-       (* (/ -1 3) (+ (- (. δ~i_k Ric_j_l) (. δ~i_l Ric_j_k))-                      (- (. Ric~i_k g_j_l) (. Ric~i_l g_j_k))))-       (* (/ scalar-curvature 12) (- (. δ~i_k g_j_l) (. δ~i_l g_j_k))))))--C~#_#_#_#-;(tensor {5 5 5 5} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2) 0 0 0 (* 2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 (* 2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 (* 2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* 2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 2 0 0 0 -2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2) 0 0 0 (* 2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 (* 2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 0 0 0 0 0 0 (* 2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 2 0 0 0 0 0 0 0 -2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* 2 (sin θ)^2) 0 0 0 (* -2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 (* 2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 0 0 (* 2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 -2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* 2 (sin θ)^2) 0 0 0 0 0 0 0 (* -2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* 2 (sin θ)^2 (sin φ)^2) 0 0 0 (* -2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 (* 2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 -2 0 0 0 0 0 0 0 0 0 0 0 0 0 (* 2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 (* -2 (sin θ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* 2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 (* -2 (sin θ)^2 (sin φ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (* 2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 (* -2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )~#_#_#_#--;;-;; Wodzicki-Chern-Simons class-;;--(let {[[$es $os] (even-and-odd-permutations 5)]}-  (- (sum' (map (lambda [$σ] (.' C~u_1_s_(σ 1) C~s_t_(σ 3)_(σ 2) C~t_u_(σ 5)_(σ 4))) es))-     (sum' (map (lambda [$σ] (.' C~u_1_s_(σ 1) C~s_t_(σ 3)_(σ 2) C~t_u_(σ 5)_(σ 4))) os))))-;0
− sample/math/geometry/riemann-curvature-tensor-of-S5.egi 
@@ -1,109 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|θ φ ψ η δ|])--(define $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-;;--(define $e ((flip ∂/∂) x~# X_#))-e-;[|[| (* -1 r (sin θ)) (* r (cos θ) (cos φ)) (* r (cos θ) (sin φ) (cos ψ)) (* r (cos θ) (sin φ) (sin ψ) (cos η)) (* r (cos θ) (sin φ) (sin ψ) (sin η) (cos δ)) (* r (cos θ) (sin φ) (sin ψ) (sin η) (sin δ)) |]-;  [| 0 (* -1 r (sin θ) (sin φ)) (* r (sin θ) (cos φ) (cos ψ)) (* r (sin θ) (cos φ) (sin ψ) (cos η)) (* r (sin θ) (cos φ) (sin ψ) (sin η) (cos δ)) (* r (sin θ) (cos φ) (sin ψ) (sin η) (sin δ)) |]-;  [| 0 0 (* -1 r (sin θ) (sin φ) (sin ψ)) (* r (sin θ) (sin φ) (cos ψ) (cos η)) (* r (sin θ) (sin φ) (cos ψ) (sin η) (cos δ)) (* r (sin θ) (sin φ) (cos ψ) (sin η) (sin δ)) |]-;  [| 0 0 0 (* -1 r (sin θ) (sin φ) (sin ψ) (sin η)) (* r (sin θ) (sin φ) (sin ψ) (cos η) (cos δ)) (* r (sin θ) (sin φ) (sin ψ) (cos η) (sin δ)) |]-;  [| 0 0 0 0 (* -1 r (sin θ) (sin φ) (sin ψ) (sin η) (sin δ)) (* r (sin θ) (sin φ) (sin ψ) (sin η) (cos δ)) |] |]--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {5 5}))-(define $g~~ (M.inverse g_#_#))-g_#_#;[| [| r^2 0 0 0 0 |] [| 0 (* r^2 (sin θ)^2) 0 0 0 |] [| 0 0 (* r^2 (sin θ)^2 (sin φ)^2) 0 0 |] [| 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 |] [| 0 0 0 0 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) |] |]_#_#-g~#~#;[| [| (/ 1 r^2) 0 0 0 0 |] [| 0 (/ 1 (* r^2 (sin θ)^2)) 0 0 0 |] [| 0 0 (/ 1 (* r^2 (sin θ)^2 (sin φ)^2)) 0 0 |] [| 0 0 0 (/ 1 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2)) 0 |] [| 0 0 0 0 (/ 1 (* r^2 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2)) |] |]~#~#--(with-symbols {i j k} (. g~i~j g_j_k))-;[| [| 1 0 0 0 0 |] [| 0 1 0 0 0 |] [| 0 0 1 0 0 |] [| 0 0 0 1 0 |] [| 0 0 0 0 1 |] |]--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_#_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~#_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#--(define $R____ (with-symbols {i} (. g_i_# R~i_#_#_#)))--R_#_#_#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))--Ric_#_#;[| [| 4 0 0 0 0 |] [| 0 (* 4 (sin θ)^2) 0 0 0 |] [| 0 0 (* 4 (sin θ)^2 (sin φ)^2) 0 0 |] [| 0 0 0 (* 4 (sin θ)^2 (sin φ)^2 (sin ψ)^2) 0 |] [| 0 0 0 0 (* 4 (sin θ)^2 (sin φ)^2 (sin ψ)^2 (sin η)^2) |] |]_#_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature;(/ 20 r^2)--;;-;; Conformal curvature tensor-;;--(define $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)))-     (* (/ scalar-curvature 2) (- (. g_i_l g_k_m) (. g_i_m g_k_l)))))--C_#_#_#_#--;;-;; Wodzicki-Chern-Simons class-;;--(let {[[$es $os] (even-and-odd-permutations 5)]}-  (- (sum (map (lambda [$σ] (. R~u_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4))) es))-     (sum (map (lambda [$σ] (. R~u_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4))) os))))-;0
− sample/math/geometry/riemann-curvature-tensor-of-S7-conformal.egi 
@@ -1,81 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|α β γ δ ε ζ η|])--(define $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 ε) (cos ζ))-             (* r (sin α) (sin β) (sin γ) (sin δ) (sin ε) (sin ζ) (cos η))-             (* r (sin α) (sin β) (sin γ) (sin δ) (sin ε) (sin ζ) (sin η))-             |])--;;-;; Local basis-;;--(define $e ((flip ∂/∂) x~# X_#))-e--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(* (a α β γ δ ε ζ η)^2 (V.* e_%1 e_%2)) {7 7}))-(define $g~~ (M.inverse g_#_#))-g_#_#;-g~#~#;--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))--Ric_#_#;--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature--;;-;; Wodzicki-Chern-Simons class-;;--(let {[[$es $os] (even-and-odd-permutations 7)]}-  (- (sum (map (lambda [$σ] (debug (. R~v_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4) R~u_v_(σ 7)_(σ 6)))) es))-     (sum (map (lambda [$σ] (debug (. R~v_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4) R~u_v_(σ 7)_(σ 6)))) os))))-;
− sample/math/geometry/riemann-curvature-tensor-of-S7.egi 
@@ -1,92 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|α β γ δ ε ζ η|])--(define $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 ε) (cos ζ))-             (* r (sin α) (sin β) (sin γ) (sin δ) (sin ε) (sin ζ) (cos η))-             (* r (sin α) (sin β) (sin γ) (sin δ) (sin ε) (sin ζ) (sin η))-             |])--;;-;; Local basis-;;--(define $e ((flip ∂/∂) x~# X_#))-e--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {7 7}))-(define $g~~ (M.inverse g_#_#))-g_#_#;[| [| r^2 0 0 0 0 0 0 |] [| 0 (* r^2 (sin α)^2) 0 0 0 0 0 |] [| 0 0 (* r^2 (sin α)^2 (sin β)^2) 0 0 0 0 |] [| 0 0 0 (* r^2 (sin α)^2 (sin β)^2 (sin γ)^2) 0 0 0 |] [| 0 0 0 0 (* r^2 (sin α)^2 (sin β)^2 (sin γ)^2 (sin δ)^2) 0 0 |] [| 0 0 0 0 0 (* r^2 (sin α)^2 (sin β)^2 (sin γ)^2 (sin δ)^2 (sin ε)^2) 0 |] [| 0 0 0 0 0 0 (* r^2 (sin α)^2 (sin β)^2 (sin γ)^2 (sin δ)^2 (sin ε)^2 (sin ζ)^2) |] |]_#_#-g~#~#;[| [| (/ 1 r^2) 0 0 0 0 0 0 |] [| 0 (/ 1 (* r^2 (sin α)^2)) 0 0 0 0 0 |] [| 0 0 (/ 1 (* r^2 (sin α)^2 (sin β)^2)) 0 0 0 0 |] [| 0 0 0 (/ 1 (* r^2 (sin α)^2 (sin β)^2 (sin γ)^2)) 0 0 0 |] [| 0 0 0 0 (/ 1 (* r^2 (sin α)^2 (sin β)^2 (sin γ)^2 (sin δ)^2)) 0 0 |] [| 0 0 0 0 0 (/ 1 (* r^2 (sin α)^2 (sin β)^2 (sin γ)^2 (sin δ)^2 (sin ε)^2)) 0 |] [| 0 0 0 0 0 0 (/ 1 (* r^2 (sin α)^2 (sin β)^2 (sin γ)^2 (sin δ)^2 (sin ε)^2 (sin ζ)^2)) |] |]~#~#--(with-symbols {i j k} (. g~i~j g_j_k))-;[| [| 1 0 0 0 0 0 0 |] [| 0 1 0 0 0 0 0 |] [| 0 0 1 0 0 0 0 |] [| 0 0 0 1 0 0 0 |] [| 0 0 0 0 1 0 0 |] [| 0 0 0 0 0 1 0 |] [| 0 0 0 0 0 0 1 |] |]--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_l x~k)-        (∂/∂ g_j_k x~l)-        (* -1 (∂/∂ g_k_l x~j)))))--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))--Ric_#_#;-;[|[| 6 0 0 0 0 0 0 |]-;  [| 0 (* 6 (sin α)^2) 0 0 0 0 0 |]-;  [| 0 0 (* 6 (sin α)^2 (sin β)^2) 0 0 0 0 |]-;  [| 0 0 0 (* 6 (sin α)^2 (sin β)^2 (sin γ)^2) 0 0 0 |]-;  [| 0 0 0 0 (* 6 (sin α)^2 (sin β)^2 (sin γ)^2 (sin δ)^2) 0 0 |]-;  [| 0 0 0 0 0 (* 6 (sin α)^2 (sin β)^2 (sin γ)^2 (sin δ)^2 (sin ε)^2) 0 |]-;  [| 0 0 0 0 0 0 (* 6 (sin α)^2 (sin β)^2 (sin γ)^2 (sin δ)^2 (sin ε)^2 (sin ζ)^2) |]-;  |]_#_#--;;-;; Scalar curvature-;;--(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))--scalar-curvature;(/ 42 r^2)--;;-;; Wodzicki-Chern-Simons class-;;--(let {[[$es $os] (even-and-odd-permutations 7)]}-  (- (sum (map (lambda [$σ] (. R~v_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4) R~u_v_(σ 7)_(σ 6))) es))-     (sum (map (lambda [$σ] (. R~v_1_s_(σ 1) R~s_t_(σ 3)_(σ 2) R~t_u_(σ 5)_(σ 4) R~u_v_(σ 7)_(σ 6))) os))))-;0
− sample/math/geometry/riemann-curvature-tensor-of-Schwarzschild-metric.egi 
@@ -1,87 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|t r θ φ|])--;;-;; Metric tensor-;;--(define $g__-  [|[| (/ '(- (* c^2 r) (* 2 G M)) (* c^2 r)) 0 0 0 |]-    [| 0 (/ -1 (/ '(- (* c^2 r) (* 2 G M)) (* c^2 r))) 0 0 |]-    [| 0 0 (* -1 r^2) 0 |]-    [| 0 0 0 (* -1 r^2 (sin θ)^2) |]-    |])--(define $g~~ (M.inverse g_#_#))-g~#~#-;[|[| (/ (* c^2 r) '(+ (* c^2 r) (* -2 G M))) 0 0 0 |]-;  [| 0 (/ (* -1 '(+ (* c^2 r) (* -2 G M))) (* c^2 r)) 0 0 |]-;  [| 0 0 (/ -1 r^2) 0 |]-;  [| 0 0 0 (/ -1 (* r^2 (sin θ)^2)) |]|]~#~#---(with-symbols {i j k} (. g~i~j g_j_k))-;[| [| 1 0 0 0 |] [| 0 1 0 0 |] [| 0 0 1 0 |] [| 0 0 0 1 |] |]--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_j_k_l-  (* (/ 1 2)-     (+ (∂/∂ g_j_k x~l)-        (∂/∂ g_j_l x~k)-        (* -1 (∂/∂ g_k_l x~j)))))--Γ_1_#_#;[| [| 0 (/ (+ (* c^2 r) (* -1 '(+ (* c^2 r) (* -2 G M)))) (* 2 c^2 r^2)) 0 0 |] [| (/ (+ (* c^2 r) (* -1 '(+ (* c^2 r) (* -2 G M)))) (* 2 c^2 r^2)) 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#_#-Γ_2_#_#;[| [| (/ (+ (* -1 c^2 r) '(+ (* c^2 r) (* -2 G M))) (* 2 c^2 r^2)) 0 0 0 |] [| 0 (/ (+ (* -1 c^2 '(+ (* c^2 r) (* -2 G M))) (* c^4 r)) (* 2 '(+ (* c^2 r) (* -2 G M))^2)) 0 0 |] [| 0 0 r 0 |] [| 0 0 0 (* r (sin θ)^2) |] |]_#_#-Γ_3_#_#;[| [| 0 0 0 0 |] [| 0 0 (* -1 r) 0 |] [| 0 (* -1 r) 0 0 |] [| 0 0 0 (* r^2 (sin θ) (cos θ)) |] |]_#_#-Γ_4_#_#;[| [| 0 0 0 0 |] [| 0 0 0 (* -1 r (sin θ)^2) |] [| 0 0 0 (* -1 r^2 (sin θ) (cos θ)) |] [| 0 (* -1 r (sin θ)^2) (* -1 r^2 (sin θ) (cos θ)) 0 |] |]_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--Γ~1_#_#;[| [| 0 (/ (+ (* c^2 r) (* -1 '(+ (* c^2 r) (* -2 G M)))) (* 2 '(+ (* c^2 r) (* -2 G M)) r)) 0 0 |] [| (/ (+ (* c^2 r) (* -1 '(+ (* c^2 r) (* -2 G M)))) (* 2 '(+ (* c^2 r) (* -2 G M)) r)) 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#_#-Γ~2_#_#;[| [| (/ (+ (* '(+ (* c^2 r) (* -2 G M)) c^2 r) (* -1 '(+ (* c^2 r) (* -2 G M))^2)) (* 2 c^4 r^3)) 0 0 0 |] [| 0 (/ (+ '(+ (* c^2 r) (* -2 G M)) (* -1 c^2 r)) (* 2 r '(+ (* c^2 r) (* -2 G M)))) 0 0 |] [| 0 0 (/ (* -1 '(+ (* c^2 r) (* -2 G M))) c^2) 0 |] [| 0 0 0 (/ (* -1 '(+ (* c^2 r) (* -2 G M)) (sin θ)^2) c^2) |] |]_#_#-Γ~3_#_#;[| [| 0 0 0 0 |] [| 0 0 (/ 1 r) 0 |] [| 0 (/ 1 r) 0 0 |] [| 0 0 0 (* -1 (sin θ) (cos θ)) |] |]_#_#-Γ~4_#_#;[| [| 0 0 0 0 |] [| 0 0 0 (/ 1 r) |] [| 0 0 0 (/ (cos θ) (sin θ)) |] [| 0 (/ 1 r) (/ (cos θ) (sin θ)) 0 |] |]_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (expand-all (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-                   (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l))))))--R~#_#_1_1;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_1_2;[| [| 0 (/ (* 2 G M) (+ (* c^2 r^3) (* -2 G M r^2))) 0 0 |] [| (/ (+ (* 2 G M c^2 r) (* -4 G^2 M^2)) (* c^4 r^4)) 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_1_3;[| [| 0 0 (/ (* -1 G M) (* c^2 r)) 0 |] [| 0 0 0 0 |] [| (/ (+ (* -1 G M c^2 r) (* 2 G^2 M^2)) (* c^4 r^4)) 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_1_4;[| [| 0 0 0 (/ (* -1 G M (sin θ)^2) (* c^2 r)) |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| (/ (+ (* -1 G M c^2 r) (* 2 G^2 M^2)) (* c^4 r^4)) 0 0 0 |] |]~#_#-R~#_#_2_1;[| [| 0 (/ (* -2 G M) (+ (* c^2 r^3) (* -2 G M r^2))) 0 0 |] [| (/ (+ (* -2 G M c^2 r) (* 4 G^2 M^2)) (* c^4 r^4)) 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_2_2;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_2_3;[| [| 0 0 0 0 |] [| 0 0 (/ (* -1 G M) (* c^2 r)) 0 |] [| 0 (/ (* G M) (+ (* r^3 c^2) (* -2 r^2 G M))) 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_2_4;[| [| 0 0 0 0 |] [| 0 0 0 (/ (* -1 G M (sin θ)^2) (* c^2 r)) |] [| 0 0 0 0 |] [| 0 (/ (* G M) (+ (* r^3 c^2) (* -2 r^2 G M))) 0 0 |] |]~#_#-R~#_#_3_1;[| [| 0 0 (/ (* G M) (* c^2 r)) 0 |] [| 0 0 0 0 |] [| (/ (+ (* G M c^2 r) (* -2 G^2 M^2)) (* c^4 r^4)) 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_3_2;[| [| 0 0 0 0 |] [| 0 0 (/ (* G M) (* r c^2)) 0 |] [| 0 (/ (* -1 G M) (+ (* r^3 c^2) (* -2 r^2 G M))) 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_3_3;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#-R~#_#_3_4;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 (/ (* 2 G M (sin θ)^2) (* c^2 r)) |] [| 0 0 (/ (* -2 G M) (* c^2 r)) 0 |] |]~#_#-R~#_#_4_1;[| [| 0 0 0 (/ (* G M (sin θ)^2) (* c^2 r)) |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| (/ (+ (* G M c^2 r) (* -2 G^2 M^2)) (* c^4 r^4)) 0 0 0 |] |]~#_#-R~#_#_4_2;[| [| 0 0 0 0 |] [| 0 0 0 (/ (* G M (sin θ)^2) (* r c^2)) |] [| 0 0 0 0 |] [| 0 (/ (* -1 G M) (+ (* r^3 c^2) (* -2 r^2 G M))) 0 0 |] |]~#_#-R~#_#_4_3;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 (/ (* -2 G M (sin θ)^2) (* c^2 r)) |] [| 0 0 (/ (* 2 G M) (* c^2 r)) 0 |] |]~#_#-R~#_#_4_4;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]~#_#--;;-;; Ricci curvature-;;--(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))--Ric_#_#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#_#
sample/math/geometry/riemann-curvature-tensor-of-T2.egi view
@@ -1,129 +1,69 @@-;;;-;;; Coordinates for Torus-;;;--(define $x [|θ φ|])--(define $X [|(* '(+ (* a (cos θ)) b) (cos φ)) ; = x-             (* '(+ (* a (cos θ)) b) (sin φ)) ; = y-             (* a (sin θ))                    ; = z-             |])--;;-;; Local basis-;;--(define $e ((flip ∂/∂) x~# X_#))-(assert-equal "Local basis"-  e_#_#-  [|[| (* -1 a (sin θ) (cos φ)) (* -1 a (sin θ) (sin φ)) (* a (cos θ)) |]-    [| (* -1 '(+ (* a (cos θ)) b) (sin φ)) (* '(+ (* a (cos θ)) b) (cos φ)) 0 |]-    |]_#_#)--;;-;; Metric tensor-;;--(define $g__ (generate-tensor 2#(V.* e_%1 e_%2) {2 2}))-(define $g~~ (M.inverse g_#_#))--(assert-equal "Metric tensor 1" g_#_# [| [| a^2 0 |] [| 0 '(+ (* a (cos θ)) b)^2 |] |]_#_#)-(assert-equal "Metroc tensor 2" g~#~# [| [| (/ 1 a^2) 0 |] [| 0 (/ 1 '(+ (* a (cos θ)) b)^2) |] |]~#~#)--;;-;; Christoffel symbols of the first kind-;;--(define $Γ_i_j_k-  (* (/ 1 2)-     (+ (∂/∂ g_i_j x~k)-        (∂/∂ g_i_k x~j)-        (* -1 (∂/∂ g_j_k x~i)))))--(assert-equal "Christoffel symbols of the first kind" Γ_#_#_# (tensor {2 2 2} {0 0 0 (* '(+ (* a (cos θ)) b) a (sin θ)) 0 (* -1 '(+ (* a (cos θ)) b) a (sin θ)) (* -1 '(+ (* a (cos θ)) b) a (sin θ)) 0} )_#_#_#)-(assert-equal "Christoffel symbols of the first kind" Γ_1_#_# [| [| 0 0 |] [| 0 (* '(+ (* a (cos θ)) b) a (sin θ)) |] |]_#_#)-(assert-equal "Christoffel symbols of the first kind" Γ_2_#_# [| [| 0 (* -1 '(+ (* a (cos θ)) b) a (sin θ)) |] [| (* -1 '(+ (* a (cos θ)) b) a (sin θ)) 0 |] |]_#_#)--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__ (with-symbols {i} (. g~#~i Γ_i_#_#)))--(assert-equal "Christoffel symbols of the second kind" Γ~#_#_# (tensor {2 2 2} {0 0 0 (/ (* '(+ (* a (cos θ)) b) (sin θ)) a) 0 (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) 0} )~#_#_#)-(assert-equal "Christoffel symbols of the second kind" Γ~1_#_# [| [| 0 0 |] [| 0 (/ (* '(+ (* a (cos θ)) b) (sin θ)) a) |] |]_#_#)-(assert-equal "Christoffel symbols of the second kind" Γ~2_#_# [| [| 0 (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) |] [| (/ (* -1 a (sin θ)) '(+ (* a (cos θ)) b)) 0 |] |]_#_#)--;;-;; Covariant derivative of metric tensor-;;-(define $∇g___-  (with-symbols {i j m n}-    (- (∂/∂ g_i_j x~m)-       (. Γ~n_m_i g_n_j)-       (. Γ~n_m_j g_i_n))))--(assert-equal "Covariant derivative of metric tensor" ∇g_#_#_# (tensor {2 2 2} {0 0 0 0 0 0 0 0} ))--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--(assert-equal "Riemann curvature" R~#_#_#_# (tensor {2 2 2 2} {0 0 0 0 0 (/ (* '(+ (* a (cos θ)) b) (cos θ)) a) (/ (* -1 '(+ (* a (cos θ)) b) (cos θ)) a) 0 0 (/ (* -1 a (cos θ)) '(+ (* a (cos θ)) b)) (/ (* a (cos θ)) '(+ (* a (cos θ)) b)) 0 0 0 0 0} )~#_#_#_#)-(assert-equal "Riemann curvature" R~#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]~#_#)-(assert-equal "Riemann curvature" R~#_#_1_2 [| [| 0 (/ (* '(+ (* a (cos θ)) b) (cos θ)) a) |] [| (/ (* -1 a (cos θ)) '(+ (* a (cos θ)) b)) 0 |] |]~#_#)-(assert-equal "Riemann curvature" R~#_#_2_1 [| [| 0 (/ (* -1 '(+ (* a (cos θ)) b) (cos θ)) a) |] [| (/ (* a (cos θ)) '(+ (* a (cos θ)) b)) 0 |] |]~#_#)-(assert-equal "Riemann curvature" R~#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]~#_#)+-- Parameters+x := [| θ, φ |] -(define $R____ (with-symbols {i} (. g_i_# R~i_#_#_#)))+X := [| '(a * cos θ + b) * cos φ -- x+      , '(a * cos θ + b) * sin φ -- y+      , a * sin θ                -- z+      |] -(assert-equal "Riemann curvature" R_#_#_#_# (tensor {2 2 2 2} {0 0 0 0 0 (* a '(+ (* a (cos θ)) b) (cos θ)) (* -1 a '(+ (* a (cos θ)) b) (cos θ)) 0 0 (* -1 '(+ (* a (cos θ)) b) a (cos θ)) (* '(+ (* a (cos θ)) b) a (cos θ)) 0 0 0 0 0} )_#_#_#_#)-(assert-equal "Riemann curvature" R_#_#_1_1 [| [| 0 0 |] [| 0 0 |] |]_#_#)-(assert-equal "Riemann curvature" R_#_#_1_2 [| [| 0 (* a '(+ (* a (cos θ)) b) (cos θ)) |] [| (* -1 '(+ (* a (cos θ)) b) a (cos θ)) 0 |] |]_#_#)-(assert-equal "Riemann curvature" R_#_#_2_1 [| [| 0 (* -1 a '(+ (* a (cos θ)) b) (cos θ)) |] [| (* '(+ (* a (cos θ)) b) a (cos θ)) 0 |] |]_#_#)-(assert-equal "Riemann curvature" R_#_#_2_2 [| [| 0 0 |] [| 0 0 |] |]_#_#)+e_i_j := ∂/∂ X_j x~i -;;-;; Ricci curvature-;;+-- Metric tensors+g_i_j := generateTensor (\x y -> V.* e_x_# e_y_#) [2, 2]+g~i~j := M.inverse g_#_# -(define $Ric__ (with-symbols {i} (contract + R~i_#_i_#)))+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 |] |]~#~# -(assert-equal "Ricci curvature" Ric_#_# [| [| (/ (* a (cos θ)) '(+ (* a (cos θ)) b)) 0 |] [| 0 (/ (* '(+ (* a (cos θ)) b) (cos θ)) a) |] |]_#_#)+-- Christoffel symbols+Γ_i_j_k := (1 / 2) * (∂/∂ g_i_k x~j + ∂/∂ g_i_j x~k - ∂/∂ g_j_k x~i) -;;-;; Scalar curvature-;;+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 |] |]_#_# -(define $scalar-curvature (with-symbols {j k} (. g~j~k Ric_j_k)))+Γ~i_j_k := withSymbols [m]+  g~i~m . Γ_m_j_k -(assert-equal "Scalar curvature" scalar-curvature (/ (* 2 (cos θ)) (* a '(+ (* a (cos θ)) b))))+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 |] |]_#_# -;;-;; Covariant derivative of Riemann curvature tensor-;;+-- Riemann curvature+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 -(define $∇R_____-  (with-symbols {i j k l m n}-    (- (∂/∂ R_i_j_k_l x~m)-       (. Γ~n_m_i R_n_j_k_l)-       (. Γ~n_m_j R_i_n_k_l)-       (. Γ~n_m_k R_i_j_n_l)-       (. Γ~n_m_l R_i_j_k_n))))+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 |] |]~#_# -(assert-equal "Covariant derivative of Riemann curvature tensor"-  ∇R_#_#_#_#_#-  (tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 (+ (* -1 a '(+ (* a (cos θ)) b) (sin θ)) (* a^2 (sin θ) (cos θ))) 0 (+ (* a '(+ (* a (cos θ)) b) (sin θ)) (* -1 a^2 (sin θ) (cos θ))) 0 0 0 0 0 (+ (* '(+ (* a (cos θ)) b) a (sin θ)) (* -1 a^2 (sin θ) (cos θ))) 0 (+ (* -1 '(+ (* a (cos θ)) b) a (sin θ)) (* a^2 (sin θ) (cos θ))) 0 0 0 0 0 0 0 0 0 0 0} )_#_#_#_#_#)+-- Ricci curvature+Ric_i_j := withSymbols [m]+  sum (contract R~m_i_m_j) -;;-;; Second Bianchi identity-;;+-- Scalar curvature+scalarCurvature := withSymbols [i, j]+  g~i~j . Ric_i_j -(assert-equal "Second Bianchi identity"-  (with-symbols {i j k l m} (+ ∇R_i_j_k_l_m ∇R_i_j_l_m_k ∇R_i_j_m_k_l))-  (tensor {2 2 2 2 2} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} ))+assertEqual "scalar curvature"+  scalarCurvature+  (2 * cos θ / (a * '(a * cos θ + b)))
− sample/math/geometry/riemann-curvature-tensor-of-empty-Schwarzschild-spacetime.egi 
@@ -1,68 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|t r θ φ|])--;;-;; Metric tensor-;;--(define $g__-  [|[| 1 0 0 0 |]-    [| 0 -1 0 0 |]-    [| 0 0 (* -1 r^2) 0 |]-    [| 0 0 0 (* -1 r^2 (sin θ)^2) |]-    |])--(define $g~~ (M.inverse g_#_#))-g~#~#-;[|[| 1 0 0 0 |]-;  [| 0 -1 0 0 |]-;  [| 0 0 (/ 1 (* -1 r^2)) 0 |]-;  [| 0 0 0 (/ 1 (* -1 r^2 (sin θ)^2)) |]-;  |]~#~#--(with-symbols {i j k} (. g~i~j g_j_k))-;[| [| 1 0 0 0 |] [| 0 1 0 0 |] [| 0 0 1 0 |] [| 0 0 0 1 |] |]--;;-;; Christoffel symbols of the first kind-;;--(define $Γ___-  (with-symbols {j k l}-    (* (/ 1 2)-       (+ (∂/∂ g_j_l x~k)-          (∂/∂ g_j_k x~l)-          (* -1 (∂/∂ g_k_l x~j))))))--Γ_1_#_#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#_#-Γ_2_#_#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 r 0 |] [| 0 0 0 (* r (sin θ)^2) |] |]_#_#-Γ_3_#_#;[| [| 0 0 0 0 |] [| 0 0 (* -1 r) 0 |] [| 0 (* -1 r) 0 0 |] [| 0 0 0 (* r^2 (sin θ) (cos θ)) |] |]_#_#-Γ_4_#_#;[| [| 0 0 0 0 |] [| 0 0 0 (* -1 r (sin θ)^2) |] [| 0 0 0 (* -1 r^2 (sin θ) (cos θ)) |] [| 0 (* -1 r (sin θ)^2) (* -1 r^2 (sin θ) (cos θ)) 0 |] |]_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__-  (with-symbols {i j k l}-    (. g~i~j Γ_j_k_l)))--Γ~1_#_#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]_#_#-Γ~2_#_#;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 (* -1 r) 0 |] [| 0 0 0 (* -1 r (sin θ)^2) |] |]_#_#-Γ~3_#_#;[| [| 0 0 0 0 |] [| 0 0 (/ -1 (* -1 r)) 0 |] [| 0 (/ -1 (* -1 r)) 0 0 |] [| 0 0 0 (* -1 (sin θ) (cos θ)) |] |]_#_#-Γ~4_#_#;[| [| 0 0 0 0 |] [| 0 0 0 (/ -1 (* -1 r)) |] [| 0 0 0 (/ (* -1 (cos θ)) (* -1 (sin θ))) |] [| 0 (/ -1 (* -1 r)) (/ (* -1 (cos θ)) (* -1 (sin θ))) 0 |] |]_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))---R~#_#_#_#;(tensor {4 4 4 4} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )~#_#_#_#
− sample/math/geometry/riemann-curvature-tensor-of-spherical-space.egi 
@@ -1,62 +0,0 @@-;;;-;;; Parameters-;;;--(define $x [|r θ φ|])--;;-;; Metric tensor-;;--(define $g__-  [|[| 1 0 0 |]-    [| 0 r^2 0 |]-    [| 0 0 (* r^2 (sin θ)^2) |]-    |])--(define $g~~ (M.inverse g_#_#))-g~#~#-;[|[| 1 0 0 |]-;  [| 0 (/ 1 r^2) 0 |]-;  [| 0 0 (/ 1 (* r^2 (sin θ)^2)) |]|]~#~#--(with-symbols {i j k} (. g~i~j g_j_k))-;[| [| 1 0 0 |] [| 0 1 0 |] [| 0 0 1 |] |]--;;-;; Christoffel symbols of the first kind-;;--(define $Γ___-  (with-symbols {j k l}-    (* (/ 1 2)-       (+ (∂/∂ g_j_l x~k)-          (∂/∂ g_j_k x~l)-          (* -1 (∂/∂ g_k_l x~j))))))--Γ_1_#_#;[| [| 0 0 0 |] [| 0 (* -1 r) 0 |] [| 0 0 (* -1 r (sin θ)^2) |] |]_#_#-Γ_2_#_#;[| [| 0 r 0 |] [| r 0 0 |] [| 0 0 (* -1 r^2 (sin θ) (cos θ)) |] |]_#_#-Γ_3_#_#;[| [| 0 0 (* r (sin θ)^2) |] [| 0 0 (* r^2 (sin θ) (cos θ)) |] [| (* r (sin θ)^2) (* r^2 (sin θ) (cos θ)) 0 |] |]_#_#--;;-;; Christoffel symbols of the second kind-;;--(define $Γ~__-  (with-symbols {i j k l}-    (. g~i~j Γ_j_k_l)))--Γ~1_#_#;[| [| 0 0 0 |] [| 0 (* -1 r) 0 |] [| 0 0 (* -1 r (sin θ)^2) |] |]_#_#-Γ~2_#_#;[| [| 0 (/ 1 r) 0 |] [| (/ 1 r) 0 0 |] [| 0 0 (* -1 (sin θ) (cos θ)) |] |]_#_#-Γ~3_#_#;[| [| 0 0 (/ 1 r) |] [| 0 0 (/ (cos θ) (sin θ)) |] [| (/ 1 r) (/ (cos θ) (sin θ)) 0 |] |]_#_#--;;-;; Riemann curvature tensor-;;--(define $R~i_j_k_l-  (with-symbols {m}-    (+ (- (∂/∂ Γ~i_j_l x~k) (∂/∂ Γ~i_j_k x~l))-       (- (. Γ~m_j_l Γ~i_m_k) (. Γ~m_j_k Γ~i_m_l)))))--R~#_#_#_#;(tensor {3 3 3 3} {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} )~#_#_#_#
− sample/math/geometry/surface.egi 
@@ -1,55 +0,0 @@-; We can bound f to a specific function.-; (define $f (lambda [$x $y] (+ (** x 2) (** y 2))))--(define $v1 [| 1 0 (∂/∂ (f x y) x) |])-(define $v2 [| 0 1 (∂/∂ (f x y) y) |])--v1;[| 1 0 (f|1 x y) |]-v2;[| 0 1 (f|2 x y) |]--(define $v3 (cross-product v1 v2))--v3;[| (* -1 (f|1 x y)) (* -1 (f|2 x y)) 1 |]--(define $e3 (/ v3 (sqrt '(V.* v3 v3))))--e3-;[|(/ (* -1 (f|1 x y))-;     (sqrt '(+ (f|1 x y)^2 (f|2 x y)^2 1)))-;  (/ (* -1 (f|2 x y))-;     (sqrt '(+ (f|1 x y)^2 (f|2 x y)^2 1)))-;  (/ 1-;     (sqrt '(+ (f|1 x y)^2 (f|2 x y)^2 1)))|]--(define $E (V.* v1 v1))-(define $F (V.* v1 v2))-(define $G (V.* v2 v2))--E;(+ 1 (f|1 x y)^2)-F;(* (f|1 x y) (f|2 x y)-G;(+ 1 (f|2 x y)^2)--(define $L (V.* (∂/∂ v1 x) e3))-(define $M (V.* (∂/∂ v1 y) e3))-;(define $M (V.* (∂/∂ v2 x) e3))-(define $N (V.* (∂/∂ v2 y) e3))--L;(/ (f|1|1 x y) (sqrt '(+ (f|1 x y)^2 (f|2 x y)^2 1)))-M;(/ (f|1|2 x y) (sqrt '(+ (f|1 x y)^2 (f|2 x y)^2 1)))-N;(/ (f|2|2 x y) (sqrt '(+ (f|1 x y)^2 (f|2 x y)^2 1)))--(define $K (/ (- (* L N) (** M 2))-              '(- (* E G) (** F 2))))-(define $H (/ (+ (* 'E N) (* 'G L) (* -2 F M))-              (* 2 '(- (* E G) (** F 2)))))--K-;(/ (+ (* (f|1|1 x y) (f|2|2 x y)) (* -1 (f|1|2 x y)^2))-;   '(+ (f|1 x y)^2 (f|2 x y)^2 1)^2)-H-;(/ (+ (* '(+ 1 (f|1 x y)^2) (f|2|2 x y))-;      (* '(+ 1 (f|2 x y)^2) (f|1|1 x y))-;      (* -2 (f|1 x y) (f|2 x y) (f|1|2 x y)))-;   (* 2-;      (sqrt '(+ (f|1 x y)^2 (f|2 x y)^2 1))-;      '(+ 1 (f|2 x y)^2 (f|1 x y)^2)))
− sample/math/geometry/trigonometric-identities.egi 
@@ -1,42 +0,0 @@-(coefficients (* (+ (cos α) (* i (sin α))) (+ (cos β) (* i (sin β))))-              i)-;{(+ (* (cos α) (cos β)) (* -1 (sin α) (sin β))) (+ (* (cos α) (sin β)) (* (sin α) (cos β)))}--;(cos (+ α β)) = (+ (* (cos α) (cos β)) (* -1 (sin α) (sin β)))-;(sin (+ α β)) = (+ (* (cos α) (sin β)) (* (sin α) (cos β)))---(coefficients (* (+ (cos α) (* i (sin α))) (- (cos β) (* i (sin β))))-              i)-;{(+ (* (cos α) (cos β)) (* (sin α) (sin β))) (+ (* -1 (cos α) (sin β)) (* (sin α) (cos β)))}--;(cos (- α β)) = (+ (* (cos α) (cos β)) (* (sin α) (sin β)))-;(sin (- α β)) = (+ (* -1 (cos α) (sin β)) (* (sin α) (cos β)))---(coefficients (+ (* (+ (cos α) (* i (sin α))) (+ (cos β) (* i (sin β))))-                 (* (+ (cos α) (* i (sin α))) (- (cos β) (* i (sin β)))))-              i)-;{(* 2 (cos α) (cos β)) (* 2 (sin α) (cos β))}--;(* (cos α) (cos β)) = (* (/ 1 2) (+ (cos (+ α β)) (cos (- α β))))-;(* (sin α) (cos β)) = (* (/ 1 2) (+ (sin (+ α β)) (sin (- α β))))---(coefficients (- (* (+ (cos α) (* i (sin α))) (+ (cos β) (* i (sin β))))-                 (* (+ (cos α) (* i (sin α))) (- (cos β) (* i (sin β)))))-              i)-;{(* -2 (sin α) (sin β)) (* 2 (cos α) (sin β))}--;(* (sin α) (sin β)) = (* (/ -1 2) (- (cos (+ α β)) (cos (- α β))))-;(* (cos α) (sin β)) = (* (/  1 2) (- (sin (+ α β)) (sin (- α β))))---(coefficients (** (+ (cos α) (* i (sin α))) 3)-              i)-;{(+ (cos α)^3 (* -3 (cos α) (sin α)^2)) (+ (* 3 (cos α)^2 (sin α)) (* -1 (sin α)^3))}--;(cos (* 3 α)) = (+ (cos α)^3 (* -3 (cos α) (sin α)^2))-;              = (+ (* 4 (cos α)^3) (* -3 (cos α)))-;(sin (* 3 α)) = (+ (* 3 (cos α)^2 (sin α)) (* -1 (sin α)^3))-;              = (+ (* -4 (sin α)^3 (* 3 (sin α))))
− sample/math/geometry/vector-analysis.egi 
@@ -1,57 +0,0 @@-(define $N 3)--(define $g [| [| 1 0 0 |] [| 0 1 0 |] [| 0 0 1 |] |])--(define $d-  (lambda [%X]-    !((flip ∂/∂) [| x y z |] X)))--(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {i j}-        (* (sqrt (abs (M.det g_#_#)))-           (foldl . (. (subrefs A (map 1#j_%1 (between 1 k)))-                       (subrefs (ε' N k) (map 1#i_%1 (between 1 N))))-                  (map 1#g~[i_%1]~[j_%1] (between 1 k))))))))--(define $δ-  (lambda [%A]-    (let {[$r (df-order A)]}-      (* (** -1 (+ (* N r) 1))-         (hodge (d (hodge A)))))))--(define $grad d)-(define $rot d)-(define $div δ)--(define $Δ-  (lambda [%A]-    (match (tensor-order A) integer-      {[,0 (δ (d A))]-       [,N (d (δ A))]-       [_ (+ (d (δ A)) (δ (d A)))]})))--(grad (+ (** x 2) (** y 2) (** z 2)))-;[| (* 2 x) (* 2 y) (* 2 z) |]--(rot [| (** y 2) (** x 2) 0 |])-;[| [| 0 (* 2 x) 0 |] [| (* 2 y) 0 0 |] [| 0 0 0 |] |]--(div [| (** y 2) (** x 2) 0 |])-;0--(rot [| (** x 2) (** y 2) (** z 2) |])-;[| [| (* 2 x) 0 0 |] [| 0 (* 2 y) 0 |] [| 0 0 (* 2 z) |] |]--(div [| (** x 2) (** y 2) (** z 2) |])-;(+ (* 2 z) (* 2 y) (* 2 x))--(rot [| (* x 2) (* y 2) (* z 2) |])-;[| [| 2 0 0 |] [| 0 2 0 |] [| 0 0 2 |] |]--(div [| (* x 2) (* y 2) (* z 2) |])-;6--(Δ (+ (** x 2) (** y 2) (** z 2)))-;6
− sample/math/geometry/wedge-product.egi 
@@ -1,23 +0,0 @@-(define $N 3)-(define $params [| x y z |])-(define $g [| [| 1 0 0 |] [| 0 1 0 |] [| 0 0 1 |] |])--(define $wedge-  (lambda [%X %Y]-    !(. X Y)))--(define $dx [| 1 0 0 |])-(define $dy [| 0 1 0 |])-(define $dz [| 0 0 1 |])--(wedge dx dy)-;[| [| 0 1 0 |] [| 0 0 0 |] [| 0 0 0 |] |]--(df-normalize (wedge dx dy))-;[| [| 0 (/ 1 2) 0 |] [| (/ -1 2) 0 0 |] [| 0 0 0 |] |]--(wedge dz dz)-;[| [| 0 0 0 |] [| 0 0 0 |] [| 0 0 1 |] |]--(df-normalize (wedge dz dz))-;[| [| 0 0 0 |] [| 0 0 0 |] [| 0 0 0 |] |]
− sample/math/geometry/yang-mills-equation-of-U1-gauge-theory.egi 
@@ -1,77 +0,0 @@-(define $N 4)--(define $g [| [| -1 0 0 0 |] [| 0 1 0 0 |] [| 0 0 1 0 |] [| 0 0 0 1 |] |])--(define $d-  (lambda [%X]-    !((flip ∂/∂) [| t x y z |] X)))--(define $hodge-  (lambda [%A]-    (let {[$k (df-order A)]}-      (with-symbols {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] (between 1 k))))))))--(define $δ-  (lambda [%A]-    (let {[$r (df-order A)]}-      (* (** -1 (+ (* N r) 1))-         (hodge (d (hodge A)))))))--(define $Δ-  (lambda [%A]-    (match (dfr-order A) integer-      {[,0 (δ (d A))]-       [,4 (d (δ A))]-       [_ (+ (d (δ A)) (δ (d A)))]})))--(define $normalize2-  (lambda [%A]-    (with-symbols {t1 t2}-      (- A_t1_t2 A_t2_t1))))--; *(dt^dx) = -dy^dz-(hodge (wedge [| 1 0 0 0 |] [| 0 1 0 0 |]))-;[| [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 -1 |] [| 0 0 0 0 |] |]--; *(dy^dz) = dt^dx-(hodge (wedge [| 0 0 1 0 |] [| 0 0 0 1 |]))-;[| [| 0 1 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] [| 0 0 0 0 |] |]--(df-normalize (d [| (φ t x y z) (Ax t x y z) (Ay t x y z) (Az t x y z) |]))-;[|[| 0 (+ (Ax|1 t x y z) (* -1 (φ|2 t x y z))) (+ (Ay|1 t x y z) (* -1 (φ|3 t x y z))) (+ (Az|1 t x y z) (* -1 (φ|4 t x y z))) |]-;  [| (+ (φ|2 t x y z) (* -1 (Ax|1 t x y z))) 0 (+ (Ay|2 t x y z) (* -1 (Ax|3 t x y z))) (+ (Az|2 t x y z) (* -1 (Ax|4 t x y z))) |]-;  [| (+ (φ|3 t x y z) (* -1 (Ay|1 t x y z))) (+ (Ax|3 t x y z) (* -1 (Ay|2 t x y z))) 0 (+ (Az|3 t x y z) (* -1 (Ay|4 t x y z))) |]-;  [| (+ (φ|4 t x y z) (* -1 (Az|1 t x y z))) (+ (Ax|4 t x y z) (* -1 (Az|2 t x y z))) (+ (Ay|4 t x y z) (* -1 (Az|3 t x y z))) 0 |]|]--(define $F-  [|[| 0 (Ex t x y z) (Ey t x y z) (Ez t x y z) |]-    [| (* -1 (Ex t x y z)) 0 (Bz t x y z) (* -1 (By t x y z)) |]-    [| (* -1 (Ey t x y z)) (* -1 (Bz t x y z)) 0 (Bx t x y z) |]-    [| (* -1 (Ez t x y z)) (By t x y z) (* -1 (Bx t x y z)) 0 |]-    |])--(hodge (d F))-;[|(+ (* -2 (Bz|4 t x y z)) (* -2 (By|3 t x y z)) (* -2 (Bx|2 t x y z)))-;  (+ (* -2 (Ey|4 t x y z)) (* 2 (Ez|3 t x y z)) (* -2 (Bx|1 t x y z)))-;  (+ (* 2 (Ex|4 t x y z)) (* -2 (Ez|2 t x y z)) (* -2 (By|1 t x y z)))-;  (+ (* -2 (Ex|3 t x y z)) (* 2 (Ey|2 t x y z)) (* -2 (Bz|1 t x y z)))|]--;(∇ B) = 0-;(rot x E) = ∂t B-;(rot y E) = ∂t B-;(rot z E) = ∂t B--(δ F)-;[|(+ (* -2 (Ez|4 t x y z)) (* -2 (Ey|3 t x y z)) (* -2 (Ex|2 t x y z)))-;  (+ (* 2 (By|4 t x y z)) (* -2 (Bz|3 t x y z)) (* -2 (Ex|1 t x y z)))-;  (+ (* -2 (Bx|4 t x y z)) (* 2 (Bz|2 t x y z)) (* -2 (Ey|1 t x y z)))-;  (+ (* 2 (Bx|3 t x y z)) (* -2 (By|2 t x y z)) (* -2 (Ez|1 t x y z)))|]--;(∇ E) = 0-;(rot x B) = ∂t E-;(rot y B) = ∂t E-;(rot z B) = ∂t E
− sample/math/number/10bonacci.egi 
@@ -1,37 +0,0 @@-(define $m 10)--(define $A-  (generate-tensor-    (match-lambda [integer integer]-      {[[,1 _] 1]-       [[$x ,(- x 1)] 1]-       [[_ _] 0]})-    {m m}))--A-;[| [| 1 1 1 1 1 1 1 1 1 1 |] [| 1 0 0 0 0 0 0 0 0 0 |] [| 0 1 0 0 0 0 0 0 0 0 |] [| 0 0 1 0 0 0 0 0 0 0 |] [| 0 0 0 1 0 0 0 0 0 0 |] [| 0 0 0 0 1 0 0 0 0 0 |] [| 0 0 0 0 0 1 0 0 0 0 |] [| 0 0 0 0 0 0 1 0 0 0 |] [| 0 0 0 0 0 0 0 1 0 0 |] [| 0 0 0 0 0 0 0 0 1 0 |] |]--(define $B-  (generate-tensor-    (match-lambda integer-      {[,1 1]-       [_ 0]})-    {m}))--B-;[| 1 0 0 0 0 0 0 0 0 0 |]--(M.* A B)-;[| 1 1 0 0 0 0 0 0 0 0 |]--(define $M.*-mod-  (lambda [%m1 %m2]-    (modulo (b..' m1~#~j m2_j) (** 10 9))))--(M.*-mod A A)-;[| [| 2 2 2 2 2 2 2 2 2 1 |] [| 1 1 1 1 1 1 1 1 1 1 |] [| 1 0 0 0 0 0 0 0 0 0 |] [| 0 1 0 0 0 0 0 0 0 0 |] [| 0 0 1 0 0 0 0 0 0 0 |] [| 0 0 0 1 0 0 0 0 0 0 |] [| 0 0 0 0 1 0 0 0 0 0 |] [| 0 0 0 0 0 1 0 0 0 0 |] [| 0 0 0 0 0 0 1 0 0 0 |] [| 0 0 0 0 0 0 0 1 0 0 |] |]--(M.* (repeated-squaring M.*-mod A 10) B)-;[| 512 256 128 64 32 16 8 4 2 1 |]~#-(M.* (repeated-squaring M.*-mod A (** 10 18)) B)-;[| 781174235709863749 377867955633934335 842430993012717568 732703024915201024 898916287400615936 291801846997259776 348909715528105216 288982486365729408 408131585481965832 584591530883971372 |]
− sample/math/number/11th-root-of-unity.egi 
@@ -1,54 +0,0 @@-;(gen-cyclic-group (map 1#(modulo (* %1 2) 11) (between 1 10)))-;--(define $z (rtu 11))-(define $k (rtu 5))--(define $a11 (+ z^1 z^10))-(define $a12 (+ z^2 z^9))-(define $a13 (+ z^3 z^8))-(define $a14 (+ z^4 z^7))-(define $a15 (+ z^5 z^6))--(define $b10 (+ a11 a12 a13 a14 a15))--(define $b10' -1);-1--(define $b11 (+ a11 (* k a12) (* k^2 a13) (* k^3 a14)  (* k^4 a15)))-(define $b12 (+ a15 (* k a11) (* k^2 a12) (* k^3 a13)  (* k^4 a14)));(* k b11)-(define $b13 (+ a14 (* k a15) (* k^2 a11) (* k^3 a12)  (* k^4 a13)));(* k^2 b11)-(define $b14 (+ a13 (* k a14) (* k^2 a15) (* k^3 a11)  (* k^4 a12)));(* k^3 b11)-(define $b15 (+ a12 (* k a13) (* k^2 a14) (* k^3 a15)  (* k^4 a11)));(* k^4 b11)--b11-(* b11 b12)--(rt 5 (* -1 b11 b12 b13 b14 b15));-(define $b11' (rt 3 (+ 7 (* 21 w^2))))--(define $b14 (+ a11 (* w a13) (* w^2 a12)))-(define $b15 (+ a12 (* w a11) (* w^2 a13)));(* w b14)-(define $b16 (+ a13 (* w a12) (* w^2 a11)));(* w^2 b14)--;(rt 3 (* b14 b15 b16));(rt 3 (+ 7 (* 21 w)))-(define $b14' (rt 3 (+ 7 (* 21 w))))--(define $a11' (/ (+ b10' b11' b14') 3));;/ (+ -1 (rt 3 (+ 7 (* 21 w^2))) (rt 3 (+ 7 (* 21 w)))) 3)--(define $z1' (fst (q-f' 1 (* -1 a11') 1)))--z1'-;(/ (+ -1 (rt 3 (+ 7 (* 21 w^2))) (rt 3 (+ 7 (* 21 w))) (sqrt (+ -35 (* -2 (rt 3 (+ 7 (* 21 w^2)))) (* -2 (rt 3 (+ 7 (* 21 w)))) (rt 3 (+ 7 (* 21 w^2)))^2 (* 2 (rt 3 (+ 7 (* 21 w^2))) (rt 3 (+ 7 (* 21 w)))) (rt 3 (+ 7 (* 21 w)))^2))) 6)--(/ (+ -1-      (rt 3 (+ 7 (* 21 w^2)))-      (rt 3 (+ 7 (* 21 w)))-      (sqrt (+ -35-               (* -2 (rt 3 (+ 7 (* 21 w^2))))-               (* -2 (rt 3 (+ 7 (* 21 w))))-               (rt 3 (+ 7 (* 21 w^2)))^2-               (* 2 (rt 3 (+ 7 (* 21 w^2))) (rt 3 (+ 7 (* 21 w))))-               (rt 3 (+ 7 (* 21 w)))-               ^2))-      )-   6)
sample/math/number/17th-root-of-unity.egi view
@@ -1,69 +1,61 @@-;(gen-cyclic-group (map 1#(modulo (* %1 11) 17) (between 1 16)))-;{{11 5 16 10 4 15 9 3 14 8 2 13 7 1 12 6} {2 4 6 8 10 12 14 16 1 3 5 7 9 11 13 15} {5 10 15 3 8 13 1 6 11 16 4 9 14 2 7 12} {4 8 12 16 3 7 11 15 2 6 10 14 1 5 9 13} {10 3 13 6 16 9 2 12 5 15 8 1 11 4 14 7} {8 16 7 15 6 14 5 13 4 12 3 11 2 10 1 9} {3 6 9 12 15 1 4 7 10 13 16 2 5 8 11 14} {16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1} {6 12 1 7 13 2 8 14 3 9 15 4 10 16 5 11} {15 13 11 9 7 5 3 1 16 14 12 10 8 6 4 2} {12 7 2 14 9 4 16 11 6 1 13 8 3 15 10 5} {13 9 5 1 14 10 6 2 15 11 7 3 16 12 8 4} {7 14 4 11 1 8 15 5 12 2 9 16 6 13 3 10} {9 1 10 2 11 3 12 4 13 5 14 6 15 7 16 8} {14 11 8 5 2 16 13 10 7 4 1 15 12 9 6 3} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16}}--(define $z (rtu 17))--;(gen-cyclic-group {16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1})-;{{16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16}}-(define $a1 (+ z^1 z^16))-(define $a2 (+ z^2 z^15))-(define $a3 (+ z^3 z^14))-(define $a4 (+ z^4 z^13))-(define $a5 (+ z^5 z^12))-(define $a6 (+ z^6 z^11))-(define $a7 (+ z^7 z^10))-(define $a8 (+ z^8 z^9))+z := rtu 17 -;(gen-cyclic-group {4 8 12 16 3 7 11 15 2 6 10 14 1 5 9 13})-;{{4 8 12 16 3 7 11 15 2 6 10 14 1 5 9 13} {16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1} {13 9 5 1 14 10 6 2 15 11 7 3 16 12 8 4} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16}}-(define $b11 (+ a1 a4))-(define $b12 (- a1 a4));(** b12 2);(+ 4 b21 (* -2 b31))+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 -(define $b21 (+ a2 a8))-(define $b22 (- a2 a8));(** b22 2);(+ 4 b21 (* -2 b41))+b11 := a1 + a4+b12 := a1 - a4 -(define $b31 (+ a3 a5))-(define $b32 (- a3 a5));(** b32 2);(+ 4 b41 (* -2 b21))+b21 := a2 + a8+b22 := a2 - a8 -(define $b41 (+ a6 a7))-(define $b42 (- a6 a7));(** b42 2);(+ 4 b31 (* -2 b21))+b31 := a3 + a5+b32 := a3 - a5 -;(gen-cyclic-group {2 4 6 8 10 12 14 16 1 3 5 7 9 11 13 15})-;{{2 4 6 8 10 12 14 16 1 3 5 7 9 11 13 15} {4 8 12 16 3 7 11 15 2 6 10 14 1 5 9 13} {8 16 7 15 6 14 5 13 4 12 3 11 2 10 1 9} {16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1} {15 13 11 9 7 5 3 1 16 14 12 10 8 6 4 2} {13 9 5 1 14 10 6 2 15 11 7 3 16 12 8 4} {9 1 10 2 11 3 12 4 13 5 14 6 15 7 16 8} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16}}-(define $c11 (+ b11 b21))-(define $c12 (- b11 b21));(+ 8 (* -1 c11'))+b41 := a6 + a7+b42 := a6 - a7 -(define $c21 (+ b31 b41))-(define $c22 (- b31 b41));(+ 8 (* -1 c21'))+c11 := b11 + b21+c12 := b11 - b21 -(define $d10 (+ c11 c21));-1-(define $d11 (- c11 c21))-(define $d12 (- c21 c11))+c21 := b31 + b41+c22 := b31 - b41 -(define $d10' -1)+d10 := c11 + c21+d11 := c11 - c21+d12 := c21 - c11 -;(define $d11' (sqrt (* -1 d11 d12)));(sqrt 17)-(define $d11' (sqrt 17))+d10' := -1 -(define $c11' (/ (+ d10' d11') 2));(/ (+ -1 (sqrt 17)) 2)-(define $c21' (/ (- d10' d11') 2));(/ (+ -1 (* -1 (sqrt 17))) 2)+d11' := sqrt 17 -(define $c12' (sqrt (+ 8 (* -1 c11'))));(/ (sqrt (+ 34 (* -2 (sqrt 17)))) 2)-(define $c22' (sqrt (+ 8 (* -1 c21'))));(/ (sqrt (+ 34 (* 2 (sqrt 17)))) 2)+c11' := (d10' + d11') / 2+c21' := (d10' - d11') / 2+c12' := sqrt (8 + (- c11'))+c22' := sqrt (8 + (- c21')) -(define $b11' (/ (+ c11' c12') 2));(/ (+ -1 (sqrt 17) (sqrt (+ 34 (* -2 (sqrt 17))))) 4)-(define $b21' (/ (- c11' c12') 2));(/ (+ -1 (sqrt 17) (* -1 (sqrt (+ 34 (* -2 (sqrt 17)))))) 4)-(define $b31' (/ (+ c21' c22') 2));(/ (+ -1 (* -1 (sqrt 17)) (sqrt (+ 34 (* 2 (sqrt 17))))) 4)-(define $b41' (/ (- c21' c22') 2));(/ (+ -1 (* -1 (sqrt 17)) (* -1 (sqrt (+ 34 (* 2 (sqrt 17)))))) 4)+b11' := (c11' + c12') / 2+b21' := (c11' - c12') / 2+b31' := (c21' + c22') / 2+b41' := (c21' - c22') / 2 -(define $b12' (sqrt (+ 4 b21' (* -2 b31'))))-(define $b22' (sqrt (+ 4 b21' (* -2 b41'))))-(define $b32' (sqrt (+ 4 b41' (* -2 b21'))))-(define $b42' (sqrt (+ 4 b31' (* -2 b21'))))+b12' := sqrt (4 + b21' + (-2) * b31')+b22' := sqrt (4 + b21' + (-2) * b41')+b32' := sqrt (4 + b41' + (-2) * b21')+b42' := sqrt (4 + b31' + (-2) * b21') -(define $a1' (/ (+ b11' b12') 2))+a1' := (b11' + b12') / 2 -(assert-equal "17th-root-of-unity"-  a1';(+ z z^16) = (* 2 (cos (/ (* 2 pi) 17)))-  (/ (+ -1 (sqrt 17) (sqrt (+ 34 (* -2 (sqrt 17)))) (* 2 (sqrt (+ 17 (* 3 (sqrt 17)) (* -1 (sqrt (+ 34 (* -2 (sqrt 17))))) (* -2 (sqrt (+ 34 (* 2 (sqrt 17))))))))) 8)-  )+assertEqual+  "17th-root-of-unity"+  a1'+  ((-1+    + sqrt 17+    + sqrt (34 + (-2) * sqrt 17)+    + 2 * sqrt (17 + 3 * sqrt 17 + (- sqrt (34 + (-2) * sqrt 17)) + (-2) * sqrt (34 + 2 * sqrt 17))) / 8)
− sample/math/number/5th-root-of-unity.egi 
@@ -1,44 +0,0 @@-;(gen-cyclic-group (map 1#(modulo (* %1 2) 5) (between 1 4)))-;{{2 4 1 3} {4 3 2 1} {3 1 4 2} {1 2 3 4}}--(define $z (rtu 5))--(define $a11 (+ z^1 z^4))-(define $a12 (+ z^2 z^3))--(define $b10 (+ a11 a12))-(define $b11 (- a11 a12))-(define $b12 (- a12 a11))--(define $b10' -1);-1-(define $b11' (sqrt (** b11 2)));(sqrt 5)--(define $a11' (/ (+ b10' b11') 2));(/ (+ -1 (sqrt 5)) 2)-(define $a12' (/ (- b10' b11') 2));(/ (+ -1 (* -1 (sqrt 5))) 2)--(define $a21 (- z^1 z^4))-(define $a22 (- z^2 z^3))--(define $b20 (+ a21 a22))-(define $b21 (- a21 a22))-(define $b22 (- a22 a21))--;(define $b20' (sqrt (* -1 b20 b20)));(sqrt (+ (* -3 (rtu 5)^2) 4 (* -3 (rtu 5)^3) (rtu 5)^4 (rtu 5)))-(define $b20' (sqrt (+ -3 (* 4 a12'))))-;(define $b21' (sqrt (* -1 b21 b22)));(sqrt (+ (* -1 (rtu 5)^3) (* 3 (rtu 5)^4) (* -1 (rtu 5)^2) -4 (* 3 (rtu 5))))-(define $b21' (sqrt (+ -3 (* 4 a11'))))--(define $a21' (/ (+ b20' b21') 2))-(define $a22' (/ (- b20' b21') 2))--(define $z1' (/ (+ a11' a21') 2))--z1';(/ (+ -1 (sqrt 5) (sqrt (+ -5 (* -2 (sqrt 5)))) (sqrt (+ -5 (* 2 (sqrt 5))))) 4)--(** (+ (sqrt (+ -5 (* -2 (sqrt 5)))) (sqrt (+ -5 (* 2 (sqrt 5))))) 2)-;(+ -10 (* 2 (sqrt (+ -5 (* -2 (sqrt 5)))) (sqrt (+ -5 (* 2 (sqrt 5))))))--(* (+ -5 (* -2 (sqrt 5))) (+ -5 (* 2 (sqrt 5))));5--; z1' is equal to-(/ (+ -1 (sqrt 5) (sqrt (+ -10 (* -2 (sqrt 5))))) 4)
− sample/math/number/7th-root-of-unity-2.egi 
@@ -1,68 +0,0 @@-;(gen-cyclic-group (map 1#(modulo (* %1 3) 7) (between 1 6)))-;{{3 6 2 5 1 4} {2 4 6 1 3 5} {6 5 4 3 2 1} {4 1 5 2 6 3} {5 3 1 6 4 2} {1 2 3 4 5 6}}--(define $z (rtu 7))--(define $a11 (+ z   z^2 z^4))-(define $a12 (+ z^6 z^5 z^3))--(define $b10 (+ a11 a12));-1--(define $b10' b10)--(define $b11 (- a11 a12))-(define $b12 (- a12 a11))--(define $b11' (sqrt (** b11 2)))--(define $a11' (/ (+ b10' b11') 2));(/ (+ -1 (* i (sqrt 7))) 2)-(define $a12' (/ (- b10' b11') 2));(/ (+ -1 (* -1 i (sqrt 7))) 2)---(define $a21 (+ z   (* w z^2) (* w^2 z^4)))-(define $a22 (+ z^6 (* w z^5) (* w^2 z^3)))--(define $b20 (+ a21 a22))-(define $b21 (- a21 a22))-(define $b22 (- a22 a21))--(define $b20' (rt 3 (** b20 3)))-;(define $b21' (rt 3 (** b21 3)))-;(** b21 3)-;(+ (* 8 (rtu 7)) (* 8 (rtu 7)^2) (* -5 (rtu 7)^3) (* 5 (rtu 7)^4) (* -8 (rtu 7)^5) (* -8 (rtu 7)^6) (* 3 (rtu 7) w) (* 3 (rtu 7)^2 w) (* -3 (rtu 7)^5 w) (* -3 (rtu 7)^6 w) (* 3 (rtu 7)^3 w^2) (* -3 (rtu 7)^4 w^2))-(define $b21' (rt 3 (+ (* 5 a11') (* -5 a12') (* w^2 -3 a11') (* w^2 3 a12'))));Calculate manually--(define $a21' (/ (+ b20' b21') 2))-(define $a22' (/ (- b20' b21') 2))---(define $a31 (+ z   (* w^2 z^2) (* w z^4)))-(define $a32 (+ z^6 (* w^2 z^5) (* w z^3)))--(define $b30 (+ a31 a32))-(define $b31 (- a31 a32))-(define $b32 (- a32 a31))--(define $b30' (rt 3 (** b30 3)))-;(define $b31' (rt 3 (** b31 3)))-;(** b31 3)-;(+ (* 5 (rtu 7)) (* 8 (rtu 7)^2) (* -5 (rtu 7)^3) (* 5 (rtu 7)^4) (* -8 (rtu 7)^5) (* -5 (rtu 7)^6) (* -3 (rtu 7) w) (* 3 (rtu 7)^3 w) (* -3 (rtu 7)^4 w) (* 3 (rtu 7)^6 w) (* 3 (rtu 7)^2 w^2) (* -3 (rtu 7)^5 w^2))-(define $b31' (rt 3 (+ (* 5 a11') (* -5 a12') (* w -3 a11') (* w 3 a12'))));Calculate manually--(define $a31' (/ (+ b30' b31') 2))-(define $a32' (/ (- b30' b31') 2))--(define $z1' (/ (+ a11' a21' a31') 3))-(define $z6' (/ (+ a12' a22' a32') 3))--z1'-;(/ (+ -1 (* i (sqrt 7)) (rt 3 (+ 14 (* 21 w))) (rt 3 (+ (* 5 i (sqrt 7)) (* -3 i (sqrt 7) w^2))) (rt 3 (+ -7 (* -21 w))) (rt 3 (+ (* 5 i (sqrt 7)) (* -3 i (sqrt 7) w)))) 6)--(/ (+ -1-      (rt 3 (+ 14 (* 21 w)))-      (rt 3 (+ -7 (* -21 w)))-      (* i (sqrt 7))-      (rt 3 (+ (* 5 i (sqrt 7)) (* -3 i (sqrt 7) w)))-      (rt 3 (+ (* 5 i (sqrt 7)) (* -3 i (sqrt 7) w^2)))-      )-   6)
− sample/math/number/7th-root-of-unity.egi 
@@ -1,53 +0,0 @@-;(gen-cyclic-group (map 1#(modulo (* %1 3) 7) (between 1 6)))-;{{3 6 2 5 1 4} {2 4 6 1 3 5} {6 5 4 3 2 1} {4 1 5 2 6 3} {5 3 1 6 4 2} {1 2 3 4 5 6}}--(define $z (rtu 7))--(define $a11 (+ z^1 z^6))-(define $a12 (+ z^2 z^5))-(define $a13 (+ z^3 z^4))--(define $b10 (+ a11 a12 a13))--(define $b10' b10)--b10';-1--(define $b11 (+ a11 (* w a12) (* w^2 a13)))-(define $b12 (+ a13 (* w a11) (* w^2 a12)));(* w b11)-(define $b13 (+ a12 (* w a13) (* w^2 a11)));(* w^2 b11)--(define $b11' (rt 3 (* b11 b12 b13)))--b11';(rt 3 (+ 14 (* 21 w)))--(define $b14 (+ a11 (* w a13) (* w^2 a12)))-(define $b15 (+ a12 (* w a11) (* w^2 a13)));(* w b14)-(define $b16 (+ a13 (* w a12) (* w^2 a11)));(* w^2 b14)--(define $b14' (rt 3 (* b14 b15 b16)))--b14';(rt 3 (+ -7 (* -21 w)))--(define $a11' (/ (+ b10' b11' b14') 3))--a11';(/ (+ -1 (rt 3 (+ 14 (* 21 w))) (rt 3 (+ -7 (* -21 w)))) 3)---(define $z1' (fst (q-f' 1 (* -1 a11') 1)))--z1';(/ (+ -1 (rt 3 (+ 14 (* 21 w))) (rt 3 (+ -7 (* -21 w))) (sqrt (+ -35 (* -2 (rt 3 (+ 14 (* 21 w)))) (* -2 (rt 3 (+ -7 (* -21 w)))) (rt 3 (+ 14 (* 21 w)))^2 (* 2 (rt 3 (+ 14 (* 21 w))) (rt 3 (+ -7 (* -21 w)))) (rt 3 (+ -7 (* -21 w)))^2))) 6)--(/ (+ -1-      (rt 3 (+ 14 (* 21 w)))-      (rt 3 (+ -7 (* -21 w)))-      (sqrt (+ -35-               (* -2 (rt 3 (+ 14 (* 21 w))))-               (* -2 (rt 3 (+ -7 (* -21 w))))-               (rt 3 (+ 14 (* 21 w)))^2-               (rt 3 (+ -7 (* -21 w)))^2-               (* 2-                  (rt 3 (+ 14 (* 21 w)))-                  (rt 3 (+ -7 (* -21 w))))-               )))-   6)
− sample/math/number/9th-root-of-unity.egi 
@@ -1,48 +0,0 @@-;(map 1#(modulo (** 2 %1) 9) (between 1 6));{2 4 8 7 5 1}--(define $z (rtu 9))--(define $a11 (+ z^1 z^8))-(define $a12 (+ z^2 z^7))-(define $a13 (+ z^4 z^5))--(define $b10 (+ a11 a12 a13))--(define $b10' 0)--(define $b11 (+ a11 (* w a12) (* w^2 a13)))-(define $b12 (+ a13 (* w a11) (* w^2 a12)));(* w b11)-(define $b13 (+ a12 (* w a13) (* w^2 a11)));(* w^2 b11)--;(define $b11' (rt 3 (** b11 3)))-(define $b11' (* 3 (rt 3 w)));Calculate manually-;(** b11 3)-;=>(+ (* 18 w) (* 9 (rtu 9)^6) (* 9 (rtu 9)^6 w^2) (* 9 (rtu 9)^3) (* 9 (rtu 9)^3 w^2))-;=>(* 27 w)--(define $b14 (+ a11 (* w a13) (* w^2 a12)))-(define $b15 (+ a12 (* w a11) (* w^2 a13)));(* w b14)-(define $b16 (+ a13 (* w a12) (* w^2 a11)));(* w^2 b14)--;(define $b14' (rt 3 (** b14 3)))-(define $b14' (* 3 (rt 3 w^2)));Caluculate manually-;(** b14 3)-;=>(+ (* 18 w^2) (* 9 (rtu 9)^6) (* 9 (rtu 9)^6 w) (* 9 (rtu 9)^3) (* 9 (rtu 9)^3 w))-;=>(* 27 w^2)--(define $a11' (/ (+ b10' b11' b14') 3))-a11'-;(+ (rt 3 w) (rt 3 w^2))--(define $z1' (fst (q-f' 1 (* -1 a11') 1)))-z1'-;(/ (+ (rt 3 w) (rt 3 w^2) (sqrt (+ (rt 3 w)^2 (* 2 (rt 3 w) (rt 3 w^2)) (rt 3 w^2)^2 -4))) 2)--(/ (+ (rt 3 w)-      (rt 3 w^2)-      (sqrt (+ -4-               (rt 3 w)^2-               (rt 3 w^2)^2-               (* 2 (rt 3 w) (rt 3 w^2))-               )))-   2)
− sample/math/number/eisenstein-primes.egi 
@@ -1,38 +0,0 @@-(map 2#[(+ %1 (* w %2)) (* (+ %1 (* w %2)) (+ %1 (* w^2 %2)))] (match-all (take 10 nats) (set integer) [<cons $x <cons $y _>> [x y]]))--{[(+ 1 w) 1]- [(+ 1 (* 2 w)) 3] [(+ 2 w) 3]- [(+ 1 (* 3 w)) 7] [(+ 2 (* 2 w)) 4] [(+ 3 w) 7]- [(+ 1 (* 4 w)) 13] [(+ 2 (* 3 w)) 7] [(+ 3 (* 2 w)) 7] [(+ 4 w) 13]- [(+ 1 (* 5 w)) 21] [(+ 2 (* 4 w)) 12] [(+ 3 (* 3 w)) 9] [(+ 4 (* 2 w)) 12] [(+ 5 w) 21] - [(+ 1 (* 6 w)) 31] [(+ 2 (* 5 w)) 19] [(+ 3 (* 4 w)) 13] [(+ 4 (* 3 w)) 13] [(+ 5 (* 2 w)) 19] [(+ 6 w) 31]- [(+ 1 (* 7 w)) 43] [(+ 2 (* 6 w)) 28] [(+ 3 (* 5 w)) 19] [(+ 4 (* 4 w)) 16] [(+ 5 (* 3 w)) 19] [(+ 6 (* 2 w)) 28] [(+ 7 w) 43]- [(+ 1 (* 8 w)) 57] [(+ 2 (* 7 w)) 39] [(+ 3 (* 6 w)) 27] [(+ 4 (* 5 w)) 21] [(+ 5 (* 4 w)) 21] [(+ 6 (* 3 w)) 27] [(+ 7 (* 2 w)) 39] [(+ 8 w) 57] - [(+ 1 (* 9 w)) 73] [(+ 2 (* 8 w)) 52] [(+ 3 (* 7 w)) 37] [(+ 4 (* 6 w)) 28] [(+ 5 (* 5 w)) 25] [(+ 6 (* 4 w)) 28] [(+ 7 (* 3 w)) 37] [(+ 8 (* 2 w)) 52] [(+ 9 w) 73] - [(+ 1 (* 10 w)) 91] [(+ 2 (* 9 w)) 67] [(+ 3 (* 8 w)) 49] [(+ 4 (* 7 w)) 37] [(+ 5 (* 6 w)) 31] [(+ 6 (* 5 w)) 31] [(+ 7 (* 4 w)) 37] [(+ 8 (* 3 w)) 49] [(+ 9 (* 2 w)) 67] [(+ 10 w) 91]- [(+ 2 (* 10 w)) 84] [(+ 3 (* 9 w)) 63] [(+ 4 (* 8 w)) 48] [(+ 5 (* 7 w)) 39] [(+ 6 (* 6 w)) 36] [(+ 7 (* 5 w)) 39] [(+ 8 (* 4 w)) 48] [(+ 9 (* 3 w)) 63] [(+ 10 (* 2 w)) 84]- [(+ 3 (* 10 w)) 79] [(+ 4 (* 9 w)) 61] [(+ 5 (* 8 w)) 49] [(+ 6 (* 7 w)) 43] [(+ 7 (* 6 w)) 43] [(+ 8 (* 5 w)) 49] [(+ 9 (* 4 w)) 61] [(+ 10 (* 3 w)) 79]- [(+ 4 (* 10 w)) 76] [(+ 5 (* 9 w)) 61] [(+ 6 (* 8 w)) 52] [(+ 7 (* 7 w)) 49] [(+ 8 (* 6 w)) 52] [(+ 9 (* 5 w)) 61] [(+ 10 (* 4 w)) 76]- [(+ 5 (* 10 w)) 75] [(+ 6 (* 9 w)) 63] [(+ 7 (* 8 w)) 57] [(+ 8 (* 7 w)) 57] [(+ 9 (* 6 w)) 63] [(+ 10 (* 5 w)) 75]- [(+ 6 (* 10 w)) 76] [(+ 7 (* 9 w)) 67] [(+ 8 (* 8 w)) 64] [(+ 9 (* 7 w)) 67] [(+ 10 (* 6 w)) 76]- [(+ 7 (* 10 w)) 79] [(+ 8 (* 9 w)) 73] [(+ 9 (* 8 w)) 73] [(+ 10 (* 7 w)) 79]- [(+ 8 (* 10 w)) 84] [(+ 9 (* 9 w)) 81] [(+ 10 (* 8 w)) 84] - [(+ 9 (* 10 w)) 91] [(+ 10 (* 9 w)) 91]- [(+ 10 (* 10 w)) 100]- }--(filter 2#(prime? %2) (map 2#[(+ %1 (* w %2)) (* (+ %1 (* w %2)) (+ %1 (* w^2 %2)))] (match-all (take 10 nats) (set integer) [<cons $x <cons $y _>> [x y]])))--{[(+ 1 w) 1]- [(+ 1 (* 2 w)) 3] [(+ 2 w) 3]- [(+ 1 (* 3 w)) 7] [(+ 3 w) 7]- [(+ 1 (* 4 w)) 13] [(+ 2 (* 3 w)) 7] [(+ 3 (* 2 w)) 7] [(+ 4 w) 13]- [(+ 1 (* 6 w)) 31] [(+ 2 (* 5 w)) 19] [(+ 3 (* 4 w)) 13] [(+ 4 (* 3 w)) 13] [(+ 5 (* 2 w)) 19] [(+ 6 w) 31]- [(+ 1 (* 7 w)) 43] [(+ 3 (* 5 w)) 19] [(+ 5 (* 3 w)) 19] [(+ 7 w) 43]- [(+ 1 (* 9 w)) 73] [(+ 3 (* 7 w)) 37] [(+ 7 (* 3 w)) 37] [(+ 9 w) 73]- [(+ 2 (* 9 w)) 67] [(+ 4 (* 7 w)) 37] [(+ 5 (* 6 w)) 31] [(+ 6 (* 5 w)) 31] [(+ 7 (* 4 w)) 37] [(+ 9 (* 2 w)) 67]- [(+ 3 (* 10 w)) 79] [(+ 4 (* 9 w)) 61] [(+ 6 (* 7 w)) 43] [(+ 7 (* 6 w)) 43] [(+ 9 (* 4 w)) 61] [(+ 10 (* 3 w)) 79]- [(+ 5 (* 9 w)) 61] [(+ 9 (* 5 w)) 61]- [(+ 7 (* 9 w)) 67] [(+ 9 (* 7 w)) 67]- [(+ 7 (* 10 w)) 79] [(+ 8 (* 9 w)) 73] [(+ 9 (* 8 w)) 73] [(+ 10 (* 7 w)) 79]- }
− sample/math/number/euler-totient-function.egi 
@@ -1,108 +0,0 @@-(define $φ-  (lambda [$n]-    (* n-       (product (map (lambda [$p] (- 1 (/ 1 p)))-                     (unique (p-f n)))))))--(take 100 (map2 2#[%1 %2 (p-f %2)] nats (map φ nats)))--{[1 1 {}]- [2 1 {}]- [3 2 {2}]- [4 2 {2}]- [5 4 {2 2}]- [6 2 {2}]- [7 6 {2 3}]- [8 4 {2 2}]- [9 6 {2 3}]- [10 4 {2 2}]- [11 10 {2 5}]- [12 4 {2 2}]- [13 12 {2 2 3}]- [14 6 {2 3}]- [15 8 {2 2 2}]- [16 8 {2 2 2}]- [17 16 {2 2 2 2}]- [18 6 {2 3}]- [19 18 {2 3 3}]- [20 8 {2 2 2}]- [21 12 {2 2 3}]- [22 10 {2 5}]- [23 22 {2 11}]- [24 8 {2 2 2}]- [25 20 {2 2 5}]- [26 12 {2 2 3}]- [27 18 {2 3 3}]- [28 12 {2 2 3}]- [29 28 {2 2 7}]- [30 8 {2 2 2}]- [31 30 {2 3 5}]- [32 16 {2 2 2 2}]- [33 20 {2 2 5}]- [34 16 {2 2 2 2}]- [35 24 {2 2 2 3}]- [36 12 {2 2 3}]- [37 36 {2 2 3 3}]- [38 18 {2 3 3}]- [39 24 {2 2 2 3}]- [40 16 {2 2 2 2}]- [41 40 {2 2 2 5}]- [42 12 {2 2 3}]- [43 42 {2 3 7}]- [44 20 {2 2 5}]- [45 24 {2 2 2 3}]- [46 22 {2 11}]- [47 46 {2 23}]- [48 16 {2 2 2 2}]- [49 42 {2 3 7}]- [50 20 {2 2 5}]- [51 32 {2 2 2 2 2}]- [52 24 {2 2 2 3}]- [53 52 {2 2 13}]- [54 18 {2 3 3}]- [55 40 {2 2 2 5}]- [56 24 {2 2 2 3}]- [57 36 {2 2 3 3}]- [58 28 {2 2 7}]- [59 58 {2 29}]- [60 16 {2 2 2 2}]- [61 60 {2 2 3 5}]- [62 30 {2 3 5}]- [63 36 {2 2 3 3}]- [64 32 {2 2 2 2 2}]- [65 48 {2 2 2 2 3}]- [66 20 {2 2 5}]- [67 66 {2 3 11}]- [68 32 {2 2 2 2 2}]- [69 44 {2 2 11}]- [70 24 {2 2 2 3}]- [71 70 {2 5 7}]- [72 24 {2 2 2 3}]- [73 72 {2 2 2 3 3}]- [74 36 {2 2 3 3}]- [75 40 {2 2 2 5}]- [76 36 {2 2 3 3}]- [77 60 {2 2 3 5}]- [78 24 {2 2 2 3}]- [79 78 {2 3 13}]- [80 32 {2 2 2 2 2}]- [81 54 {2 3 3 3}]- [82 40 {2 2 2 5}]- [83 82 {2 41}]- [84 24 {2 2 2 3}]- [85 64 {2 2 2 2 2 2}]- [86 42 {2 3 7}]- [87 56 {2 2 2 7}]- [88 40 {2 2 2 5}]- [89 88 {2 2 2 11}]- [90 24 {2 2 2 3}]- [91 72 {2 2 2 3 3}]- [92 44 {2 2 11}]- [93 60 {2 2 3 5}]- [94 46 {2 23}]- [95 72 {2 2 2 3 3}]- [96 32 {2 2 2 2 2}]- [97 96 {2 2 2 2 2 3}]- [98 42 {2 3 7}]- [99 60 {2 2 3 5}]- [100 40 {2 2 2 5}]}
− sample/math/number/fib.egi 
@@ -1,1 +0,0 @@-(define $F (lambda [$n] (* (/ 1 (sqrt 5)) (- (** (/ (+ 1 (sqrt 5)) 2) n) (** (/ (- 1 (sqrt 5)) 2) n)))))
− sample/math/number/gaussian-primes.egi 
@@ -1,36 +0,0 @@-(map 2#[(+ %1 (* i %2)) (* (+ %1 (* i %2)) (+ %1 (* -1 i %2)))] (match-all (take 10 nats) (set integer) [<cons $x <cons $y _>> [x y]]))--{[(+ 1 i) 2] - [(+ 1 (* 2 i)) 5] [(+ 2 i) 5]- [(+ 1 (* 3 i)) 10] [(+ 2 (* 2 i)) 8] [(+ 3 i) 10]- [(+ 1 (* 4 i)) 17] [(+ 2 (* 3 i)) 13] [(+ 3 (* 2 i)) 13] [(+ 4 i) 17]- [(+ 1 (* 5 i)) 26] [(+ 2 (* 4 i)) 20] [(+ 3 (* 3 i)) 18] [(+ 4 (* 2 i)) 20] [(+ 5 i) 26]- [(+ 1 (* 6 i)) 37] [(+ 2 (* 5 i)) 29] [(+ 3 (* 4 i)) 25] [(+ 4 (* 3 i)) 25] [(+ 5 (* 2 i)) 29] [(+ 6 i) 37] - [(+ 1 (* 7 i)) 50] [(+ 2 (* 6 i)) 40] [(+ 3 (* 5 i)) 34] [(+ 4 (* 4 i)) 32] [(+ 5 (* 3 i)) 34] [(+ 6 (* 2 i)) 40] [(+ 7 i) 50]- [(+ 1 (* 8 i)) 65] [(+ 2 (* 7 i)) 53] [(+ 3 (* 6 i)) 45] [(+ 4 (* 5 i)) 41] [(+ 5 (* 4 i)) 41] [(+ 6 (* 3 i)) 45] [(+ 7 (* 2 i)) 53] [(+ 8 i) 65]- [(+ 1 (* 9 i)) 82] [(+ 2 (* 8 i)) 68] [(+ 3 (* 7 i)) 58] [(+ 4 (* 6 i)) 52] [(+ 5 (* 5 i)) 50] [(+ 6 (* 4 i)) 52] [(+ 7 (* 3 i)) 58] [(+ 8 (* 2 i)) 68] [(+ 9 i) 82]- [(+ 1 (* 10 i)) 101] [(+ 2 (* 9 i)) 85] [(+ 3 (* 8 i)) 73] [(+ 4 (* 7 i)) 65] [(+ 5 (* 6 i)) 61] [(+ 6 (* 5 i)) 61] [(+ 7 (* 4 i)) 65] [(+ 8 (* 3 i)) 73] [(+ 9 (* 2 i)) 85] [(+ 10 i) 101]- [(+ 2 (* 10 i)) 104] [(+ 3 (* 9 i)) 90] [(+ 4 (* 8 i)) 80] [(+ 5 (* 7 i)) 74] [(+ 6 (* 6 i)) 72] [(+ 7 (* 5 i)) 74] [(+ 8 (* 4 i)) 80] [(+ 9 (* 3 i)) 90] [(+ 10 (* 2 i)) 104]- [(+ 3 (* 10 i)) 109] [(+ 4 (* 9 i)) 97] [(+ 5 (* 8 i)) 89] [(+ 6 (* 7 i)) 85] [(+ 7 (* 6 i)) 85] [(+ 8 (* 5 i)) 89] [(+ 9 (* 4 i)) 97] [(+ 10 (* 3 i)) 109]- [(+ 4 (* 10 i)) 116] [(+ 5 (* 9 i)) 106] [(+ 6 (* 8 i)) 100] [(+ 7 (* 7 i)) 98] [(+ 8 (* 6 i)) 100] [(+ 9 (* 5 i)) 106] [(+ 10 (* 4 i)) 116]- [(+ 5 (* 10 i)) 125] [(+ 6 (* 9 i)) 117] [(+ 7 (* 8 i)) 113] [(+ 8 (* 7 i)) 113] [(+ 9 (* 6 i)) 117] [(+ 10 (* 5 i)) 125]- [(+ 6 (* 10 i)) 136] [(+ 7 (* 9 i)) 130] [(+ 8 (* 8 i)) 128] [(+ 9 (* 7 i)) 130] [(+ 10 (* 6 i)) 136]- [(+ 7 (* 10 i)) 149] [(+ 8 (* 9 i)) 145] [(+ 9 (* 8 i)) 145] [(+ 10 (* 7 i)) 149]- [(+ 8 (* 10 i)) 164] [(+ 9 (* 9 i)) 162] [(+ 10 (* 8 i)) 164]- [(+ 9 (* 10 i)) 181] [(+ 10 (* 9 i)) 181]- [(+ 10 (* 10 i)) 200]- }--(filter 2#(prime? %2) (map 2#[(+ %1 (* i %2)) (* (+ %1 (* i %2)) (+ %1 (* -1 i %2)))] (match-all (take 10 nats) (set integer) [<cons $x <cons $y _>> [x y]])))--{[(+ 1 i) 2]- [(+ 1 (* 2 i)) 5] [(+ 2 i) 5]- [(+ 1 (* 4 i)) 17] [(+ 2 (* 3 i)) 13] [(+ 3 (* 2 i)) 13] [(+ 4 i) 17]- [(+ 1 (* 6 i)) 37] [(+ 2 (* 5 i)) 29] [(+ 5 (* 2 i)) 29] [(+ 6 i) 37]- [(+ 2 (* 7 i)) 53] [(+ 4 (* 5 i)) 41] [(+ 5 (* 4 i)) 41] [(+ 7 (* 2 i)) 53]- [(+ 1 (* 10 i)) 101] [(+ 3 (* 8 i)) 73] [(+ 5 (* 6 i)) 61] [(+ 6 (* 5 i)) 61] [(+ 8 (* 3 i)) 73] [(+ 10 i) 101]- [(+ 3 (* 10 i)) 109] [(+ 4 (* 9 i)) 97] [(+ 5 (* 8 i)) 89] [(+ 8 (* 5 i)) 89] [(+ 9 (* 4 i)) 97] [(+ 10 (* 3 i)) 109]- [(+ 7 (* 8 i)) 113] [(+ 8 (* 7 i)) 113]- [(+ 7 (* 10 i)) 149] [(+ 10 (* 7 i)) 149]- [(+ 9 (* 10 i)) 181] [(+ 10 (* 9 i)) 181]- }
− sample/math/number/napier.egi 
@@ -1,21 +0,0 @@-;;;;;-;;;;; Calucualate Napier's constant-;;;;;--(define $calculate-napier-  (lambda [$n]-    (sum (take n (map (lambda [$i] (/ 1 (fact i))) nats0)))))--(test (calculate-napier 1))-(test (calculate-napier 2))-(test (calculate-napier 3))-(test (calculate-napier 4))-(test (calculate-napier 5))-(test (calculate-napier 6))-(test (calculate-napier 7))-(test (calculate-napier 8))-(test (calculate-napier 9))-(test (calculate-napier 10))-(test (rtof (calculate-napier 10)))-(test (rtof (calculate-napier 100)))-(test (rtof (calculate-napier 200)))
− sample/math/number/pi.egi 
@@ -1,32 +0,0 @@-;;;;;-;;;;; Calucualate Pi-;;;;;--;(define $calculate-pi-;  (lambda [$n]-;    (foldr (lambda [$x $y] (+ x (/ 1 y))) 1 (take n {3 7 15 1 292 @(repeat1 1)}))))--;(define $odds (map (compose (* $ 2) (- $ 1)) nats))--;(define $calculate-pi-;  (lambda [$n]-;    (+ 3 (foldr (lambda [$x $y] (/ x (+ 6 y))) 1 (take n (map (power $ 2) odds))))))--(define $calculate-pi-  (lambda [$n]-    (/ 4 (foldr (lambda [$x $y] (+ (- (* 2 x) 1) (/ (power x 2) y))) 1 (take n nats)))))--(test (calculate-pi 1))-(test (calculate-pi 2))-(test (calculate-pi 3))-(test (calculate-pi 4))-(test (calculate-pi 5))-(test (calculate-pi 6))-(test (calculate-pi 7))-(test (calculate-pi 8))-(test (calculate-pi 9))-(test (calculate-pi 10))-(test (rtof (calculate-pi 100)))-(test (rtof (calculate-pi 1000)))-(test (rtof (calculate-pi 2000)))-(test pi)
− sample/math/number/sum-of-cubes.egi 
@@ -1,23 +0,0 @@-;;;;;-;;;;;-;;;;; Sum of Cubes-;;;;;-;;;;;--; Infintite list of sum of cubes.-; -- [m n (+ m^3 n^3)]-(define $sum-of-cubes-  (let {[$cube (lambda [$x] (* x (* x x)))]}-    (match-all nats (list integer)-      [<join _ (& <cons $m _> <join _ <cons $n _>>)> [m n (+ (cube m) (cube n))]])))--; sample output-(test (take 10 sum-of-cubes))--; list numbers that is the sum of two non-zero cube numbers-(test (take 2 (match-all sum-of-cubes (list [integer integer integer])-                [<join _ <cons [$x1 $y1 $c]-                  <join _ <cons [$x2 $y2 ,c]-                   _>>>>-                 [[x1 y1 c] [x2 y2 c]]]-                )))
− sample/math/number/sum-of-squares.egi 
@@ -1,36 +0,0 @@-;;;;;-;;;;;-;;;;; Sum of Squares-;;;;;-;;;;;--; Infintite list of sum of squres.-; -- [m n (+ m^2 n^2)]-(define $sum-of-squares-  (let {[$square (lambda [$x] (* x x))]}-    (match-all nats (list integer)-      [<join _ (& <cons $m _> <join _ <cons $n _>>)> [m n (+ (square m) (square n))]])))--; sample output-(test (take 30 sum-of-squares))--; list numbers that is the sum of two non-zero square numbers in two distinct way-(test (let {[$n 2]}-        (take 5 (match-all sum-of-squares (list [integer integer integer])-                  [<join _ <cons [$x_1 $y_1 $c]-                    (loop $i [2 n]-                      <join _ <cons [$x_i $y_i ,c] ...>>-                      _)>>-                   (map (lambda [$i] [x_i y_i c]) (between 1 n))]))))--; prime-factorize sum of squares-; -- [m n {p1 p2 ...}]-(define $sum-of-squares-pf (map (match-lambda [integer integer integer] {[[$m $n $c] [m n (p-f c)]]}) sum-of-squares))--; sample output-(test (take 30 sum-of-squares-pf))--; list prime numbers that is the sum of two non-zero square numbers-(test (take 30 (match-all sum-of-squares-pf (list [integer integer (multiset integer)])-                 [<join _ <cons [$m $n <cons $p <nil>>] _>> [m n p]])))-
sample/math/number/tribonacci.egi view
@@ -1,39 +1,40 @@-(define $m 3)+m := 3 -(define $A-  (generate-tensor-    (match-lambda [integer integer]-      {[[,1 _] 1]-       [[$x ,(- x 1)] 1]-       [[_ _] 0]})-    {m m}))+A :=+  generateTensor+    (\match as (integer, integer) with+      | (#1, _) -> 1+      | ($x, #(x - 1)) -> 1+      | (_, _) -> 0)+    [m, m]+ A-;[| [| 1 1 1 |] [| 1 0 0 |] [| 0 1 0 |] |]+-- [| [| 1, 1, 1 |], [| 1, 0, 0 |], [| 0, 1, 0 |] |] -(define $B-  (generate-tensor-    (match-lambda integer-      {[,1 1]-       [_ 0]})-    {m}))+B :=+  generateTensor+    (\match as integer with+      | #1 -> 1+      | _ -> 0)+    [m]  B-;[| 1 0 0 |]+-- [| 1, 0, 0 |] -(M.* A B)-;[| 1 1 0 |]+M.* A B+--[| 1, 1, 0 |] -(M.* (M.power A 2) B)-;[| 2 1 1 |]+M.* (M.power A 2) B+--[| 2, 1, 1 |] -(M.* (M.power A 3) B)-;[| 4 2 1 |]+M.* (M.power A 3) B+--[| 4, 2, 1 |] -(M.* (M.power A 4) B)-;[| 7 4 2 |]+M.* (M.power A 4) B+--[| 7, 4, 2 |] -(M.* (M.power A 5) B)-;[| 13 7 4 |]+M.* (M.power A 5) B+--[| 13, 7, 4 |] -(M.* (M.power A 100) B)-;[| 180396380815100901214157639 98079530178586034536500564 53324762928098149064722658 |]+M.* (M.power A 100) B+--[| 180396380815100901214157639, 98079530178586034536500564, 53324762928098149064722658 |]
− sample/math/number/zeta.egi 
@@ -1,9 +0,0 @@-(define $zeta-  (lambda [$n]-    (rtof (foldl + 0 (take n (map (lambda [$n] (* (/ 1 n) (/ 1 n))) nats))))))--(test (zeta 100))-(test (zeta 1000))-(test (zeta 10000))--(test (/ (* pi pi) 6))
− sample/math/others/mobius-transformation.egi 
@@ -1,25 +0,0 @@-(define $f-  (lambda [$z]-    (/ (+ (* a z) b) (+ (* c z) d))))--(define $f1-  (lambda [$z]-    (+ z (/ d c))))--(define $f2-  (lambda [$z]-    (/ 1 z)))--(define $f3-  (lambda [$z]-    (* z-       (/ (* -1 (- (* a d) (* b c)))-          c^2))))--(define $f4-  (lambda [$z]-    (+ (/ a c) z)))--(assert-equal "mobius transformation"-  (f4 (f3 (f2 (f1 z))))-  (/ (+ (* a z) b) (+ (* c z) d)))
− sample/mickey.egi 
@@ -1,10 +0,0 @@-(define $mickey'-  (lambda [$cs]-    (match cs (list char)-      {[<snoc $z <snoc $y <snoc $x (& <snoc _ _> $hs)>>>-        {@(mickey' hs) c#, x y z}]-       [_ cs]})))--(define $mickey (lambda [$s] (pack (mickey' (unpack s)))))--(mickey "10000000000")
− sample/n-queen.egi 
@@ -1,65 +0,0 @@-(define $eight-queen-  (match-all {1 2 3 4 5 6 7 8} (multiset integer)-    [<cons $a_1-      <cons (& !,(- a_1 1) !,(+ a_1 1)-               $a_2)-       <cons (& !,(- a_1 2) !,(+ a_1 2)-                !,(- a_2 1) !,(+ a_2 1)-                $a_3)-        <cons (& !,(- a_1 3) !,(+ a_1 3)-                 !,(- a_2 2) !,(+ a_2 2)-                 !,(- a_3 1) !,(+ a_3 1)-                 $a_4)-          <cons (& !,(- a_1 4) !,(+ a_1 4)-                   !,(- a_2 3) !,(+ a_2 3)-                   !,(- a_3 2) !,(+ a_3 2)-                   !,(- a_4 1) !,(+ a_4 1)-                   $a_5)-           <cons (& !,(- a_1 5) !,(+ a_1 5)-                    !,(- a_2 4) !,(+ a_2 4)-                    !,(- a_3 3) !,(+ a_3 3)-                    !,(- a_4 2) !,(+ a_4 2)-                    !,(- a_5 1) !,(+ a_5 1)-                    $a_6)-            <cons (& !,(- a_1 6) !,(+ a_1 6)-                     !,(- a_2 5) !,(+ a_2 5)-                     !,(- a_3 4) !,(+ a_3 4)-                     !,(- a_4 3) !,(+ a_4 3)-                     !,(- a_5 2) !,(+ a_5 2)-                     !,(- a_6 1) !,(+ a_6 1)-                     $a_7)-             <cons (& !,(- a_1 7) !,(+ a_1 7)-                      !,(- a_2 6) !,(+ a_2 6)-                      !,(- a_3 5) !,(+ a_3 5)-                      !,(- a_4 4) !,(+ a_4 4)-                      !,(- a_5 3) !,(+ a_5 3)-                      !,(- a_6 2) !,(+ a_6 2)-                      !,(- a_7 1) !,(+ a_7 1)-                      $a_8)-              <nil>>>>>>>>>-     a]))--;(test eight-queen)--(define $n-queen-  (lambda [$n]-    (match-all (between 1 n) (multiset integer)-      [<cons $a_1-             (loop $i [2 n]-                   <cons (loop $i1 [1 (- i 1)]-                               (& !,(- a_i1 (- i i1))-                                  !,(+ a_i1 (- i i1))-                                  ...)-                               $a_i)-                         ...>-                   <nil>)>-      a])))--(test (n-queen 4))-(test (n-queen 5))-(test (n-queen 6))-(test (n-queen 7))-(test (n-queen 8))-(test (n-queen 9))-(test (n-queen 10))-(test (n-queen 11))
+ sample/n-queens.egi view
@@ -0,0 +1,29 @@+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]++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+fourQueens2
− sample/nishiwaki.egi 
@@ -1,16 +0,0 @@-(define $nishiwaki-if-  (lambda [$b $e1 $e2]-    (car (match-all b (matcher {[$ something {[#t {e1}] [#f {e2}]}]})-           [$x x]))))--(nishiwaki-if #t 1 2) ; 1--(nishiwaki-if #f 1 2) ; 2--(nishiwaki-if (eq? 1 1) 1 2) ; 1--(io (nishiwaki-if #t (print "OK") (print "NG"))) ; print "OK"--(io (nishiwaki-if #f (print "NG") (print "OK"))) ; print "OK"--(io (nishiwaki-if (eq? 1 1) (print "OK") (print "NG"))) ; print "OK"
− sample/one-minute-first.egi 
@@ -1,8 +0,0 @@-; enumerate the elements of the collection that appear twice-(test (match-all {1 2 3 4 3 5 2 6} (multiset integer) [<cons $x <cons ,x _>> x]))--; enumerate the elements of the collection that appear only once-(test (match-all {1 2 3 4 3 5 2 6} (multiset integer) [<cons $x !<cons ,x _>> x]))--; enumerate the elements of the collection if all of the three consecutive numbers from it are contained in the collection.-(test (match-all {1 2 13 14 3 15 2 6} (multiset integer) [<cons $x <cons ,(+ x 1) <cons ,(+ x 2) _>>> x]))
− sample/one-minute-second.egi 
@@ -1,5 +0,0 @@-; enumerate first 100 pairs of numbers-(test (take 100 (match-all nats (set integer) [<cons $x <cons $y _>> [x y]])))--; enumerate first 100 twin primes using non-linear patterns against the infinite list of prime numbers-(test (take 100 (match-all primes (list integer) [<join _ <cons $p <cons ,(+ p 2) _>>> [p (+ p 2)]])))
− sample/pi.egi 
@@ -1,38 +0,0 @@-(define $pi-  (lambda [$n]-    (/ 4-       (+ 1-          (foldr (lambda [$x $r]-                   (/ (power x 2)-                      (+ (+ (* x 2) 1)-                         r)))-                 0-                 (take n nats))))))--(test (pi 1))-(test (pi 2))-(test (pi 3))-(test (pi 4))-(test (pi 5))-(test (pi 6))-(test (pi 7))-(test (pi 8))-(test (pi 9))-(test (pi 10))-(test (pi 20))-(test (pi 200))--(test (show-decimal 100 (pi 1)))-(test (show-decimal 100 (pi 2)))-(test (show-decimal 100 (pi 3)))-(test (show-decimal 100 (pi 4)))-(test (show-decimal 100 (pi 5)))-(test (show-decimal 100 (pi 6)))-(test (show-decimal 100 (pi 7)))-(test (show-decimal 100 (pi 8)))-(test (show-decimal 100 (pi 9)))-(test (show-decimal 100 (pi 10)))-(test (show-decimal 100 (pi 20)))-(test (show-decimal 100 (pi 200)))--(test (show (rtof (pi 200))))
sample/poker-hands-with-joker.egi view
@@ -1,127 +1,57 @@-;;;-;;;-;;; Poker-hands demonstration-;;;-;;;+suit := algebraicDataMatcher+  | spade+  | heart+  | club+  | diamond -;;-;; Matcher definitions-;;-(define $suit-  (algebraic-data-matcher-    {<spade> <heart> <club> <diamond>}))+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+               | ($s :: _, $n :: _) -> (s, n)+  | $ as something with+    | $tgt -> [tgt] -(define $card-  (matcher-    {[<card $ $> [suit (mod 13)]-      {[<Card $x $y> {[x y]}]-       [<Joker> (match-all [{<Spade> <Heart> <Club> <Diamond>} (between 1 13)] [(set suit) (set integer)]-                  [[<cons $s _> <cons $n _>] [s n]])]}]-     [<joker> []-      {[<Joker> {[]}]}]-     [$ [something] {[$tgt {tgt}]}]}))+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"+  | card _ $n :: card _ #n :: card _ #n :: card _ #n :: _ :: []+    -> "Four of a kind"+  | card _ $m :: card _ #m :: card _ #m :: card _ $n :: card _ #n :: []+    -> "Full house"+  | card $s _ :: card #s _ :: card #s _ :: card #s _ :: card #s _ :: []+    -> "Flush"+  | card _ $n :: card _ #(n-1) :: card _ #(n-2) :: card _ #(n-3) :: card _ #(n-4) :: []+    -> "Straight"+  | card _ $n :: card _ #n :: card _ #n :: _ :: _ :: []+    -> "Three of a kind"+  | card _ $m :: card _ #m :: card _ $n :: card _ #n :: _ :: []+    -> "Two pair"+  | card _ $n :: card _ #n :: _ :: _ :: _ :: []+    -> "One pair"+  | _ :: _ :: _ :: _ :: _ :: [] -> "Nothing" -;;-;; A function that determins poker-hands-;;-(define $poker-hands-  (lambda [$cs]-    (match cs (multiset card)-      {[<cons <card $s $n>-         <cons <card ,s ,(- n 1)>-          <cons <card ,s ,(- n 2)>-           <cons <card ,s ,(- n 3)>-            <cons <card ,s ,(- n 4)>-             <nil>>>>>>-        <Straight-Flush>]-       [<cons <card _ $n>-         <cons <card _ ,n>-          <cons <card _ ,n>-            <cons <card _ ,n>-              <cons _-                <nil>>>>>>-        <Four-of-Kind>]-       [<cons <card _ $m>-         <cons <card _ ,m>-          <cons <card _ ,m>-           <cons <card _ $n>-            <cons <card _ ,n>-              <nil>>>>>>-        <Full-House>]-       [<cons <card $s _>-         <cons <card ,s _>-           <cons <card ,s _>-             <cons <card ,s _>-               <cons <card ,s _>-                 <nil>>>>>>-        <Flush>]-       [<cons <card _ $n>-         <cons <card _ ,(- n 1)>-          <cons <card _ ,(- n 2)>-           <cons <card _ ,(- n 3)>-            <cons <card _ ,(- n 4)>-             <nil>>>>>>-        <Straight>]-       [<cons <card _ $n>-         <cons <card _ ,n>-          <cons <card _ ,n>-           <cons _-            <cons _-             <nil>>>>>>-        <Three-of-Kind>]-       [<cons <card _ $m>-         <cons <card _ ,m>-          <cons <card _ $n>-            <cons <card _ ,n>-             <cons _-               <nil>>>>>>-        <Two-Pair>]-       [<cons <card _ $n>-         <cons <card _ ,n>-          <cons _-           <cons _-            <cons _-             <nil>>>>>>-        <One-Pair>]-       [<cons _-         <cons _-          <cons _-           <cons _-            <cons _-             <nil>>>>>>-        <Nothing>]})))+assertEqual "poker hand 1"+  (poker [Card Spade 5, Card Spade 6, Joker, Card Spade 8, Card Spade 9])+  "Straight flush" -;;-;; Demonstration code-;;-(assert-equal "poker-hands-with-joker 1"-  (poker-hands {<Card <Club> 12>-                <Card <Club> 10>-                <Joker>-                <Card <Club> 1>-                <Card <Club> 11>})-  <Straight-Flush>)+assertEqual "poker hand 2"+  (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Joker, Card Heart 5])+  "Four of a kind" -(assert-equal "poker-hands-with-joker 1"-  (poker-hands {<Card <Diamond> 1>-                <Card <Club> 2>-                <Joker>-                <Card <Heart> 1>-                <Card <Diamond> 2>})-  <Full-House>)+assertEqual "poker hand 3"+  (poker [Card Spade 5, Joker, Card Spade 7, Card Spade 13, Card Spade 9])+  "Flush" -(assert-equal "poker-hands-with-joker 1"-  (poker-hands {<Card <Diamond> 4>-                <Card <Club> 2>-                <Joker>-                <Card <Heart> 1>-                <Card <Diamond> 3>})-  <Straight>)+assertEqual "poker hand 4"+  (poker [Card Spade 5, Card Club 6, Joker, Card Spade 8, Card Spade 9])+  "Straight" -(assert-equal "poker-hands-with-joker 1"-  (poker-hands {<Card <Diamond> 4>-                <Card <Club> 10>-                <Joker>-                <Card <Heart> 1>-                <Card <Diamond> 3>})-  <One-Pair>)+assertEqual "poker hand 5"+  (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Joker, Card Heart 8])+  "Three of a kind"++assertEqual "poker hand 6"+  (poker [Card Spade 5, Card Diamond 10, Card Spade 7, Joker, Card Heart 8])+  "One pair"
sample/poker-hands.egi view
@@ -1,121 +1,64 @@-;;;-;;;-;;; Poker-hands demonstration-;;;-;;;+suit := algebraicDataMatcher+  | spade+  | heart+  | club+  | diamond -;;-;; Matcher definitions-;;-(define $suit-  (algebraic-data-matcher-    {<spade> <heart> <club> <diamond>}))+card := algebraicDataMatcher+  | card suit (mod 13) -(define $card-  (algebraic-data-matcher-    {<card suit (mod 13)>}))+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"+  | [card _ $n, card _ #n, card _ #n, card _ #n, _]+    -> "Four of a kind"+  | [card _ $m, card _ #m, card _ #m, card _ $n, card _ #n]+    -> "Full house"+  | [card $s _, card #s _, card #s _, card #s _, card #s _]+    -> "Flush"+  | [card _ $n, card _ #(n-1), card _ #(n-2), card _ #(n-3), card _ #(n-4)]+    -> "Straight"+  | [card _ $n, card _ #n, card _ #n, _, _]+    -> "Three of a kind"+  | [card _ $m, card _ #m, card _ $n, card _ #n, _]+    -> "Two pair"+  | [card _ $n, card _ #n, _, _, _]+    -> "One pair"+  | [_, _, _, _, _] -> "Nothing" -;;-;; A function that determines poker-hands-;;-(define $poker-hands-  (lambda [$cs]-    (match cs (multiset card)-      {[<cons <card $s $n>-         <cons <card ,s ,(- n 1)>-          <cons <card ,s ,(- n 2)>-           <cons <card ,s ,(- n 3)>-            <cons <card ,s ,(- n 4)>-             <nil>>>>>>-        "Straight flush"]-       [<cons <card _ $n>-         <cons <card _ ,n>-          <cons <card _ ,n>-            <cons <card _ ,n>-              <cons _-                <nil>>>>>>-        "Four of a kind"]-       [<cons <card _ $m>-         <cons <card _ ,m>-          <cons <card _ ,m>-           <cons <card _ $n>-            <cons <card _ ,n>-              <nil>>>>>>-        "Full house"]-       [<cons <card $s _>-         <cons <card ,s _>-           <cons <card ,s _>-             <cons <card ,s _>-               <cons <card ,s _>-                 <nil>>>>>>-        "Flush"]-       [<cons <card _ $n>-         <cons <card _ ,(- n 1)>-          <cons <card _ ,(- n 2)>-           <cons <card _ ,(- n 3)>-            <cons <card _ ,(- n 4)>-             <nil>>>>>>-        "Straight"]-       [<cons <card _ $n>-         <cons <card _ ,n>-          <cons <card _ ,n>-           <cons _-            <cons _-             <nil>>>>>>-        "Three of a kind"]-       [<cons <card _ $m>-         <cons <card _ ,m>-          <cons <card _ $n>-            <cons <card _ ,n>-             <cons _-               <nil>>>>>>-        "Two pair"]-       [<cons <card _ $n>-         <cons <card _ ,n>-          <cons _-           <cons _-            <cons _-             <nil>>>>>>-        "One pair"]-       [<cons _-         <cons _-          <cons _-           <cons _-            <cons _-             <nil>>>>>>-        "Nothing"]})))+assertEqual "poker hand 1"+  (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Spade 9])+  "Straight flush" -;;-;; Demonstration code-;;-(assert-equal "poker hands 1"-  (poker-hands {<Card <Club> 12>-                <Card <Club> 10>-                <Card <Club> 13>-                <Card <Club> 1>-                <Card <Club> 11>})-  "Straight flush")+assertEqual "poker hand 2"+  (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 5])+  "Four of a kind" -(assert-equal "poker hands 2"-  (poker-hands {<Card <Diamond> 1>-                <Card <Club> 2>-                <Card <Club> 1>-                <Card <Heart> 1>-                <Card <Diamond> 2>})-  "Full house")+assertEqual "poker hand 3"+  (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 7])+  "Full house" -(assert-equal "poker hands 3"-  (poker-hands {<Card <Diamond> 4>-                <Card <Club> 2>-                <Card <Club> 5>-                <Card <Heart> 1>-                <Card <Diamond> 3>})-  "Straight")+assertEqual "poker hand 4"+  (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 13, Card Spade 9])+  "Flush" -(assert-equal "poker hands 4"-  (poker-hands {<Card <Diamond> 4>-                <Card <Club> 10>-                <Card <Club> 5>-                <Card <Heart> 1>-                <Card <Diamond> 3>})-  "Nothing")+assertEqual "poker hand 5"+  (poker [Card Spade 5, Card Club 6, Card Spade 7, Card Spade 8, Card Spade 9])+  "Straight"++assertEqual "poker hand 6"+  (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 8])+  "Three of a kind"++assertEqual "poker hand 7"+  (poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 10])+  "Two pair"++assertEqual "poker hand 8"+  (poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 8])+  "One pair"++assertEqual "poker hand 9"+  (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Diamond 11])+  "Nothing"
− sample/prime-millionaire.egi 
@@ -1,18 +0,0 @@-(define $combs-  (lambda [$xs]-    (match-all xs (multiset something)-      [<cons $x_1-             (loop $i [2 $n]-               <cons $x_i ...>-               _)>-       (map 1#x_%1 (between 1 n))])))--(define $p?-  (lambda [$xs]-    (match xs (list integer)-      {[,{1} #f]-       [_ (prime? (read (S.concat (map show xs))))]})))--(define $main-  (lambda [$args]-    (each (compose show print) (filter p? (combs (map read args))))))
sample/primes.egi view
@@ -1,29 +1,43 @@-;;;-;;;-;;; Pattern-matching against sequence of natural numbers-;;;-;;;+--+--+-- Pattern-matching against sequence of natural numbers+--+-- -;; Extract all twin primes from the infinite list of prime numbers with pattern-matching!-(define $twin-primes-  (match-all primes (list integer)-    [<join _ <cons $p <cons ,(+ p 2) _>>>-     [p (+ p 2)]]))+-- Extract all twin primes from the infinite list of prime numbers with pattern-matching!+twinPrimes :=+  matchAll primes as list integer with+    | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2) -;; Enumerate the first 10 twin primes-(assert-equal "first 10 twin prime"-  (take 10 twin-primes)-  {[3 5] [5 7] [11 13] [17 19] [29 31] [41 43] [59 61] [71 73] [101 103] [107 109]})+-- Enumerate the first 10 twin primes+assertEqual "first 10 twin prime"+  (take 10 twinPrimes)+  [ (3, 5)+  , (5, 7)+  , (11, 13)+  , (17, 19)+  , (29, 31)+  , (41, 43)+  , (59, 61)+  , (71, 73)+  , (101, 103)+  , (107, 109) ] -;; Extract all prime-triplets from the infinite list of prime numbers with pattern-matching!-(define $prime-triplets-  (match-all primes (list integer)-    [<join _ <cons $p-              <cons (& $m (| ,(+ p 2) ,(+ p 4)))-               <cons ,(+ p 6) _>>>>-     [p m (+ p 6)]]))+-- Extract all prime-triplets from the infinite list of prime numbers with pattern-matching!+primeTriplets :=+  matchAll primes as list integer with+    | _ ++ $p :: ($m & (#(p + 2) | #(p + 4))) :: #(p + 6) :: _ -> (p, m, p + 6) -;; Enumerate the first 10 prime triplets-(assert-equal "first 10 prime triplets"-  (take 10 prime-triplets)-  {[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]})+-- Enumerate the first 10 prime triplets+assertEqual "first 10 prime triplets"+  (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) ]
− sample/randomized-3sat.egi 
@@ -1,41 +0,0 @@-;;;-;;; Randomized 3-SAT-;;;--(define $clause-satisfy?-  (lambda [$c $a]-    (any (lambda [$i $b] (if b a_i (not a_i))) c)))--(define $random-assign-  (lambda [$n]-    (generate-array [$i] n (R.car {#t #f}))))--(define $random-walk-3sat-  (match-lambda [something integer integer integer something]-    {[[$p  _ ,0 ,0  _] <Nothing>]-     [[$p $n ,0 $r  _] (R.sat-solver p n (- r 1))]-     [[$p $n $k $r $a]-      (match (randomize p) (multiset (R.multiset [integer bool]))-        {[<cons (& !?(clause-satisfy? $ a) <cons [$i _] _>) _>-          (random-walk-3sat p n (- k 1) r (A.update not i a))]-         [_ <Just a>]})]}))--(define $R.sat-solver-  (lambda [$p $n $r]-    (random-walk-3sat p n (* 3 n) r (random-assign n))))--(define $c1 {[1 #t] [2 #t] [3 #t]})-(define $c2 {[4 #t] [2 #t] [3 #f]})-(define $c3 {[1 #f] [4 #t] [3 #t]})-(define $c4 {[1 #f] [4 #f] [2 #t]})-(define $c5 {[4 #f] [2 #f] [3 #t]})-(define $c6 {[1 #f] [2 #f] [3 #f]})-(define $c7 {[1 #t] [4 #f] [3 #f]})-(define $c8 {[1 #t] [4 #t] [2 #f]})--(define $p1 {c1 c2 c3 c4 c5 c6 c7 c8})-(define $p2 {c1 c2 c3 c4 c5 c6 c8})--(R.sat-solver p1 4 3);=><Nothing>-(R.sat-solver p2 4 3);=><Just [|#f #f #t #t|]>, <Just [|#f #t #t #t|]>, or sometimes <Nothing>-
− sample/salesman.egi 
@@ -1,35 +0,0 @@-;;;-;;; Travelling Salesman Problem-;;;--(define $station string)-(define $price   integer)-(define $graph   (multiset [station (multiset [station price])]))--(define $graph-data-  {-   ["Tokyo"     {              ["Shinjuku" 200] ["Shibuya" 200] ["Mitaka" 390] ["Kinshicho" 160] ["Kitasenju" 220]}]-   ["Shinjuku"  {["Tokyo" 200]                  ["Shibuya" 160] ["Mitaka" 220] ["Kinshicho" 220] ["Kitasenju" 310]}]-   ["Shibuya"   {["Tokyo" 200] ["Shinjuku" 160]                 ["Mitaka" 310] ["Kinshicho" 220] ["Kitasenju" 310]}]-   ["Mitaka"    {["Tokyo" 390] ["Shinjuku" 220] ["Shibuya" 310]                ["Kinshicho" 470] ["Kitasenju" 550]}]-   ["Kinshicho" {["Tokyo" 160] ["Shinjuku" 220] ["Shibuya" 220] ["Mitaka" 470]                   ["Kitasenju" 220]}]-   ["Kitasenju" {["Tokyo" 220] ["Shinjuku" 310] ["Shibuya" 310] ["Mitaka" 550] ["Kinshicho" 220]                  }]-   })--(define $trips ; List up all routes that visit each city exactly once and return to Tokyo-  (match-all graph-data graph-    [<cons [,"Tokyo" <cons [$s_1 $p_1] _>]-           (loop $i [2 5]-             <cons [,s_(- i 1) <cons [$s_i $p_i] _>]-                   ...>-             <cons [,s_5 <cons [(& ,"Tokyo" $s_6) $p_6] _>]-                   _>)>-     [(sum (map (lambda [$i] p_i) (between 1 6)))-      s]]))--(define $main-  (lambda [$args]-    (do {[(print "Route list:")]-         [(each (compose show print) trips)]-         [(write "Lowest price:")]-         [(print (show (min (map (lambda [$x $y] x) trips))))]})))
− sample/salesman2.egi 
@@ -1,34 +0,0 @@-;;;-;;; Travelling Salesman Problem-;;;--(define $station string)-(define $price   integer)-(define $graph   (multiset [station (multiset [station price])]))--(define $graph-data-  {["Berlin"    {              ["St. Louis" 14] ["Oxford"  2] ["Nara" 14] ["Vancouver" 13]}]-   ["St. Louis" {["Berlin" 14]                  ["Oxford" 12] ["Nara" 18] ["Vancouver"  6]}]-   ["Oxford"    {["Berlin"  2] ["St. Louis" 12]               ["Nara" 15] ["Vancouver" 10]}]-   ["Nara"      {["Berlin" 14] ["St. Louis" 18] ["Oxford" 15]             ["Vancouver" 12]}]-   ["Vancouver" {["Berlin" 13] ["St. Louis"  6] ["Oxford" 10] ["Nara" 12]                 }]})---(define $trips ; List up all routes that visit each city exactly once and return to Tokyo-  (match-all graph-data graph-    [<cons [,"Berlin" <cons [$s_1 $p_1] _>]-           (loop $i [2 4]-             <cons [,s_(- i 1) <cons [$s_i $p_i] _>]-                   ...>-             <cons [,s_4 <cons [(& ,"Berlin" $s_5) $p_5] _>]-                   _>)>-     [(sum (map (lambda [$i] p_i) (between 1 5)))-      s]]))--(define $main-  (lambda [$args]-    (do {[(print "Route list:")]-         [(each (compose show print) trips)]-         [(write "Lowest price:")]-         [(print (show (min (map (lambda [$x $y] x) trips))))]})))-
− sample/sat/cdcl-debug.egi 
@@ -1,155 +0,0 @@-(define $literal integer)-(define $stage integer)--(define $tagged-literal [literal stage])--(define $assignment-  (matcher-    {[<deduced $ $> [tagged-literal (multiset tagged-literal)]-      {[<Deduced $e $es> {[e es]}]-       [_ {}]}]-     [<guessed $> [tagged-literal]-      {[<Guessed $e> {e}]-       [_ {}]}]-     [<whichever $> [tagged-literal]-      {[<Deduced $e _> {e}]-       [<Guessed $e> {e}]-       [_ {}]}]-     [_ [something]-      {[$tgt {tgt}]}]}))--;; Data structure for CNF--(define $to-cnf-  (lambda [$cs]-    (map (lambda [$c] [c c]) cs)))--(define $from-cnf-  (lambda [$cs]-    (map 2#%1 cs)))--;; VSIDS--(define $init-vars-  (lambda [$vs]-    (append (map (lambda [$v] [(neg v) 0]) vs)-            (map (lambda [$v] [v 0]) vs))))--(define $add-vars-  (lambda [$vs $vars]-    (match-dfs [vs vars] [(list literal) (list [literal integer])]-      {[[<nil> _] (sort/fn (lambda [$xc $yc] (compare (2#%2 yc) (2#%2 xc))) vars)]-       [[<cons $v $vs'> <join $hs <cons [,v $c] $ts>>]-        (add-vars vs' {@hs [v (+ c 1)] @ts})]})))--(define $delete-var-  (lambda [$v $vars]-    (match-dfs vars (multiset [literal integer])-      {[<cons [,v _] <cons [,(neg v) _] $vars'>> vars2]-       [_ "error: not matched in delete-var"]})))--;; Utility functions for literals and cnfs--(define $get-stage-  (lambda [$l $trail]-    (match-dfs trail (list assignment)-      {[<join _ <cons <whichever [,(neg l) $s]> _>> s]-       [_ "error: not matched in get-stage"]})))--(define $delete-literal-  (lambda [$l $cnf]-    (map (lambda [$c] [(match-all-dfs (2#%1 c) (multiset literal)-                         [<cons (and !,l $m) _> m])-                       (2#%2 c)])-         cnf)))--(define $delete-clauses-with-  (lambda [$l $cnf]-    (match-all-dfs cnf (multiset [(multiset literal) (multiset literal)])-      [<cons (and [!<cons ,l _> _] $c) _> c])))--(define $assign-true-  (lambda [$l $cnf]-    (delete-literal (neg l) (delete-clauses-with l cnf))))--;; Unit propagation--(define $unit-propagate ; rename?-  (lambda [$stage $cnf $trail]-    (unit-propagate' stage cnf trail trail)))--(define $unit-propagate' ; rename?-  (lambda [$stage $cnf $trail $otrail]-    (match-dfs trail (list assignment)-      {[<cons <whichever [$l _]> $trail'> (unit-propagate' stage (assign-true l cnf) trail' otrail)]-       [<nil> (unit-propagate'' stage (assign-true l cnf) otrail)]})))--(define $unit-propagate'' ; rename?-  (lambda [$stage $cnf $trail]-    (match-dfs cnf (multiset [(multiset literal) (multiset literal)])-      {; empty literal-       [<cons [<nil> _] _> [cnf trail]]-       ; 1-literal rule-       [<cons [<cons $l <nil>> <cons ,l $rs>] _>-        (unit-propagate'' stage (assign-true l cnf) {<Deduced [l stage] (map (lambda [$r] [r (get-stage r trail)]) rs)> @trail})]-       ; otherwise-       [_ [cnf trail]]})))--;; Learning--(define $learn-  (lambda [$stage $cl $trail]-    (match-dfs [trail cl] [(list assignment) (multiset tagged-literal)]-      {; not more than 2 literals from the current stage-       [[_ !<cons [_ ,stage] <cons [_ ,stage] _>>]-        [(min (map 2#%2 cl)) (map 2#%1 cl)]]-       ; otherwise-       [[<join _ <cons <deduced [$l ,stage] $ds> $trail'>>-         <cons [,(neg l) ,stage] $rs>]-        (learn stage (union rs ds) trail')]})))--;; Backjumping--(define $backjump-  (lambda [$stage $trail]-    (match-dfs trail (list assignment)-      {[<join _ (& <cons <guessed [_ ,stage]> _> $trail')> trail']-       [_ trail]})))--;; Guess--(define $guess-  (lambda [$vars $trail]-    (match-dfs [vars trail] [(list [literal integer]) (list assignment)]-      {[[<join _ <cons [$l _] _>> !<join _ <cons <whichever [(| ,l ,(neg l)) _]> _>>] (neg l)]})))--;; CDCL main--(define $cdcl-  (lambda [$vars $cnf]-    (cdcl' 0 0 (init-vars vars) (to-cnf cnf) {})))--(define $cdcl'-  (lambda [$count $stage $vars $cnf $trail]-    (let {[[$cnf' $trail'] (unit-propagate stage cnf (debug2 "trail: " trail))]}-      (match-dfs cnf' (multiset [(multiset literal) (multiset literal)])-        {[<nil> #t]-         [<cons [<nil> $cc] _>-          (match-dfs trail' (list assignment)-            {[<join _ <cons <guessed [$l ,stage]> $trail''>>-              (let* {[[$s $lc] (learn stage (debug2 "conflict: " (map (lambda [$l] [l (get-stage l trail')]) cc)) trail')]-                     [$trail''' (backjump s trail'')]}-                (cdcl' (+ count 1) s (add-vars lc vars) {[(debug2 "learned clause: " lc) lc] @cnf} trail'''))]-             [_ #f]})]-         [_-          (let {[$g (guess vars trail')]}-            (cdcl' (debug2 "count: " (+ count 1)) (+ stage 1) vars cnf {<Guessed [g (+ stage 1)]> @trail'}))]}))))--(define $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} {-8 4 7} {-8 -9 4} {7 17 -15} {12 -7 -14} {-10 -11 8} {2 -15 -11} {9 6 1} {-11 20 -17} {9 -15 13} {12 -7 -17} {-18 -2 20} {20 12 4} {19 11 14} {-16 18 -4} {-1 -17 -19} {-13 15 10} {-12 -14 -13} {12 -14 -7} {-7 16 10} {6 10 7} {20 14 -16} {-19 17 11} {-7 1 -20} {-5 12 15} {-4 -9 -13} {12 -11 -7} {-5 19 -8} {1 16 17} {20 -14 -15} {13 -4 10} {14 7 10} {-5 9 20} {10 1 -19} {-16 -15 -1} {16 3 -11} {-15 -10 4} {4 -15 -3} {-10 -16 11} {-8 12 -5} {14 -6 12} {1 6 11} {-13 -5 -1} {-7 -2 12} {1 -20 19} {-2 -13 -8} {15 18 4} {-11 14 9} {-6 -15 -2} {5 -12 -15} {-6 17 5} {-13 5 -19} {20 -1 14} {9 -17 15} {-5 19 -18} {-12 8 -10} {-18 14 -4} {15 -9 13} {9 -5 -1} {10 -19 -14} {20 9 4} {-9 -2 19} {-5 13 -17} {2 -10 -18} {-18 3 11} {7 -9 17} {-15 -6 -3} {-2 3 -13} {12 3 -2} {-2 -3 17} {20 -15 -16} {-5 -17 -19} {-20 -18 11} {-9 1 -5} {-19 9 17} {12 -2 17} {4 -16 -5}})--(define $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} {-13 -46 -41} {21 -4 9} {12 48 10} {24 23 15} {-8 -41 -43} {-44 -2 -35} {-27 18 31} {47 35 6} {-11 -27 41} {-33 -47 -45} {-16 36 -37} {27 -46 2} {15 -28 10} {-38 46 -39} {-33 -4 24} {-12 -45 50} {-32 -21 -15} {8 42 24} {30 -49 4} {45 -9 28} {-33 -47 -1} {1 27 -16} {-11 -17 -35} {-42 -15 45} {-19 -27 30} {3 28 12} {48 -11 -33} {-6 37 -9} {-37 13 -7} {-2 26 16} {46 -24 -38} {-13 -24 -8} {-36 -42 -21} {-37 -19 3} {-31 -50 35} {-7 -26 29} {-42 -45 29} {33 25 -6} {-45 -5 7} {-7 28 -6} {-48 31 -11} {32 16 -37} {-24 48 1} {18 -46 23} {-30 -50 48} {-21 39 -2} {24 47 42} {-36 30 4} {-5 28 -1} {-47 32 -42} {16 37 -22} {-43 42 -34} {-40 39 -20} {-49 29 6} {-41 -3 39} {-16 -12 43} {24 22 3} {47 -45 43} {45 -37 46} {-9 26 5} {-3 23 -13} {5 -34 13} {12 39 13} {22 50 37} {19 9 46} {-24 8 -27} {-28 7 21} {8 -25 50} {20 50 4} {27 36 13} {26 31 -25} {39 -44 -32} {-20 41 -10} {49 -28 35} {1 44 34} {39 35 -11} {-50 -42 -7} {-24 7 47} {-13 5 -48} {-9 -20 -23} {2 17 -19} {11 23 21} {-45 30 15} {11 26 -24} {38 33 -13} {44 -27 -7} {41 49 2} {-18 12 -37} {-2 12 -26} {-19 7 32} {-22 11 33} {8 12 -20} {16 40 -48} {-2 -24 -11} {26 -17 37} {-14 -19 46} {5 47 36} {-29 -9 19} {32 4 28} {-34 20 -46} {-4 -36 -13} {-15 -37 45} {-21 29 23} {-6 -40 7} {-42 31 -29} {-36 24 31} {-45 -37 -1} {3 -6 -29} {-28 -50 27} {44 26 5} {-17 -48 49} {12 -40 -7} {-12 31 -48} {27 32 -42} {-27 -10 1} {6 -49 10} {-24 8 43} {23 31 1} {11 -47 38} {-28 26 -13} {-40 12 -42} {-3 39 46} {17 41 46} {23 21 13} {-14 -1 -38} {20 18 6} {-50 20 -9} {10 -32 -18} {-21 49 -34} {44 23 -35} {40 -19 34} {-1 6 -12} {6 -2 -7} {32 -20 34} {-12 43 -29} {24 2 -49} {10 -4 40} {11 5 12} {-3 47 -31} {43 -23 21} {-41 -36 -50} {-8 -42 -24} {39 45 7} {7 37 -45} {41 40 8} {-50 -10 -8} {-5 -39 -14} {-22 -24 -43} {-36 40 35} {17 49 41} {-32 7 24} {-30 -8 -9} {-41 -13 -10} {31 26 -33} {17 -22 -39} {-21 28 3} {-14 46 23} {29 16 19} {42 -32 -44} {-24 10 23} {-1 -32 -21} {-8 -44 -39} {39 11 9} {19 14 -46} {46 44 -42} {37 23 -29} {32 25 20} {14 -43 -12} {-36 -18 46} {14 -26 -10} {-2 -30 5} {6 -18 46} {-26 2 -44} {20 -8 -11} {-31 3 16} {-22 -9 39} {-49 44 -42} {-45 -44 31} {-31 50 -11} {-32 -46 2} {-6 -7 17} {19 -32 48} {39 20 -10} {-22 -37 38} {-31 9 -48} {40 12 7} {-24 -4 9} {-22 49 33} {-12 43 10} {25 -30 -10} {46 47 31} {13 27 -7} {-45 32 -35} {-50 34 9} {2 34 30} {3 16 2} {-18 45 -12} {33 37 10} {43 7 -18} {-22 44 -19} {-31 -27 -42} {-3 -40 8} {-23 -31 38}})--(assert-equal "cdcl" (cdcl (between 1 20) problem20) #t) ; 2.798-(assert-equal "cdcl" (cdcl (between 1 50) problem50) #f) ; 1:10.74
sample/sat/cdcl.egi view
@@ -1,147 +1,201 @@-(define $literal integer)-(define $stage integer)+literal := integer -(define $tagged-literal [literal stage])+stage := integer -(define $assignment-  (matcher-    {[<deduced $ $> [tagged-literal (multiset tagged-literal)]-      {[<Deduced $e $es> {[e es]}]-       [_ {}]}]-     [<guessed $> [tagged-literal]-      {[<Guessed $e> {e}]-       [_ {}]}]-     [<whichever $> [tagged-literal]-      {[<Deduced $e _> {e}]-       [<Guessed $e> {e}]-       [_ {}]}]-     [_ [something]-      {[$tgt {tgt}]}]}))+taggedLiteral := (literal, stage) -;; Data structure for CNF+assignment :=+  matcher+    | deduced $ $ as (taggedLiteral, multiset taggedLiteral) with+      | Deduced $e $es -> [(e, es)]+      | _ -> []+    | guessed $ as (taggedLiteral) with+      | Guessed $e -> [e]+      | _ -> []+    | whichever $ as (taggedLiteral) with+      | Deduced $e _ -> [e]+      | Guessed $e -> [e]+      | _ -> []+    | _ as (something) with+      | $tgt -> [tgt] -(define $to-cnf-  (lambda [$cs]-    (map (lambda [$c] [c c]) cs)))+-- Data structure for CNF -(define $from-cnf-  (lambda [$cs]-    (map 2#%1 cs)))+toCnf cs := map (\c -> (c, c)) cs -;; VSIDS+fromCnf cs := map 2#%1 cs -(define $init-vars-  (lambda [$vs]-    (append (map (lambda [$v] [(neg v) 0]) vs)-            (map (lambda [$v] [v 0]) vs))))+-- VSIDS -(define $add-vars-  (lambda [$vs $vars]-    (match-dfs [vs vars] [(list literal) (list [literal integer])]-      {[[<nil> _] (sort/fn (lambda [$xc $yc] (compare (2#%2 yc) (2#%2 xc))) vars)]-       [[<cons $v $vs'> <join $hs <cons [,v $c] $ts>>]-        (add-vars vs' {@hs [v (+ c 1)] @ts})]})))+initVars vs := map (\v -> (neg v, 0)) vs ++ map (\v -> (v, 0)) vs -(define $delete-var-  (lambda [$v $vars]-    (match-dfs vars (multiset [literal integer])-      {[<cons [,v _] <cons [,(neg v) _] $vars'>> vars2]-       [_ "error: not matched in delete-var"]})))+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+    | ($v :: $vs', $hs ++ (#v, $c) :: $ts) ->+      addVars vs' (hs ++ (v, c + 1) :: ts) -;; Utility functions for literals and cnfs+deleteVar v vars :=+  matchDFS vars as multiset (literal, integer) with+    | (#v, _) :: (#(neg v), _) :: $vars' -> vars2+    | _ -> "error: not matched in delete-var" -(define $get-stage-  (lambda [$l $trail]-    (match-dfs trail (list assignment)-      {[<join _ <cons <whichever [,(neg l) $s]> _>> s]-       [_ "error: not matched in get-stage"]})))+-- Utility functions for literlas and cnfs -(define $delete-literal-  (lambda [$l $cnf]-    (map (lambda [$c] [(match-all-dfs (2#%1 c) (multiset literal)-                         [<cons (and !,l $m) _> m])-                       (2#%2 c)])-         cnf)))+getStage l trail :=+  matchDFS trail as list assignment with+    | _ ++ whichever (#(neg l), $s) :: _ -> s+    | _ -> "error: not matched in get-stage" -(define $delete-clauses-with-  (lambda [$l $cnf]-    (match-all-dfs cnf (multiset [(multiset literal) (multiset literal)])-      [<cons (and [!<cons ,l _> _] $c) _> c])))+deleteLiteral l cnf :=+  map+    (\c ->+      ( matchAllDFS 2#%1 c as multiset literal with+        | (!#l & $m) :: _ -> m+      , 2#%2 c ))+    cnf -(define $assign-true-  (lambda [$l $cnf]-    (delete-literal (neg l) (delete-clauses-with l cnf))))+deleteClausesWith l cnf :=+  matchAllDFS cnf as multiset (multiset literal, multiset literal) with+    | ((!(#l :: _), _) & $c) :: _ -> c -(define $unit-propagate-  (lambda [$stage $cnf $trail]-    (unit-propagate' stage cnf trail trail)))+assignTrue l cnf := deleteLiteral (neg l) (deleteClausesWith l cnf) -(define $unit-propagate'-  (lambda [$stage $cnf $trail $otrail]-    (match-dfs trail (list assignment)-      {[<cons <whichever [$l _]> $trail'> (unit-propagate' stage (assign-true l cnf) trail' otrail)]-       [<nil> (unit-propagate'' stage (assign-true l cnf) otrail)]})))+unitPropagate stage cnf trail := unitPropagate' stage cnf trail trail -(define $unit-propagate''-  (lambda [$stage $cnf $trail]-    (match-dfs cnf (multiset [(multiset literal) (multiset literal)])-      {; empty literal-       [<cons [<nil> _] _> [cnf trail]]-       ; 1-literal rule-       [<cons [<cons $l <nil>> <cons ,l $rs>] _>-        (unit-propagate'' stage-                          (assign-true l cnf)-                          {<Deduced [l stage] (map (lambda [$r] [r (get-stage r trail)]) rs)> @trail})]-       ; otherwise-       [_ [cnf trail]]})))+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 -(define $learn-  (lambda [$stage $cl $trail]-    (match-dfs [trail cl] [(list assignment) (multiset tagged-literal)]-      {; not more than 2 literals from the current stage-       [[_ !<cons [_ ,stage] <cons [_ ,stage] _>>]-        [(min (map 2#%2 cl)) (map 2#%1 cl)]]-       ; otherwise-       [[<join _ <cons <deduced [$l ,stage] $ds> $trail'>>-         <cons [,(neg l) ,stage] $rs>]-        (learn stage (union rs ds) trail')]})))+unitPropagate'' stage cnf trail :=+  matchDFS cnf as multiset (multiset literal, multiset literal) with+    -- empty literal+    | ([], _) :: _ -> (cnf, trail)+    -- 1-literal rule+    | ($l :: [], #l :: $rs) :: _ ->+      unitPropagate''+        stage+        (assignTrue l cnf)+        (Deduced (l, stage) (map (\r -> (r, getStage r trail)) rs) :: trail)+    -- otherwise+    | _ -> (cnf, trail) -(define $backjump-  (lambda [$stage $trail]-    (match-dfs trail (list assignment)-      {[<join _ (& <cons <guessed [_ ,stage]> _> $trail')> trail']-       [_ trail]})))+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)+    -- otherwise+    | (_ ++ deduced ($l, #stage) $ds :: $trail', (#(neg l), #stage) :: $rs) ->+      learn stage (union rs ds) trail' -(define $guess-  (lambda [$vars $trail]-    (match-dfs [vars trail] [(list [literal integer]) (list assignment)]-      {[[<join _ <cons [$l _] _>> !<join _ <cons <whichever [(| ,l ,(neg l)) _]> _>>] (neg l)]})))+backjump stage trail :=+  matchDFS trail as list assignment with+    | _ ++ (guessed (_, #stage) :: _ & $trail') -> trail'+    | _ -> trail -(define $cdcl-  (lambda [$vars $cnf]-    (cdcl' 0 0 (init-vars vars) (to-cnf cnf) {})))+guess vars trail :=+  matchDFS (vars, trail) as (list (literal, integer), list assignment) with+    | (_ ++ ($l, _) :: _, !(_ ++ whichever (#l | #(neg l), _) :: _)) -> neg l -(define $cdcl'-  (lambda [$count $stage $vars $cnf $trail]-    (let {[[$cnf' $trail'] (unit-propagate stage cnf trail)]}-      (match-dfs cnf' (multiset [(multiset literal) (multiset literal)])-        {[<nil> #t]-         [<cons [<nil> $cc] _>-          (match-dfs trail' (list assignment)-            {[<join _ <cons <guessed [$l ,stage]> $trail''>>-              (let* {[[$s $lc] (learn stage (map (lambda [$l] [l (get-stage l trail')]) cc) trail')]-                     [$trail''' (backjump s trail'')]}-                (cdcl' (+ count 1) s (add-vars lc vars) {[lc lc] @cnf} trail'''))]-             [_ #f]})]-         [_-          (let {[$g (guess vars trail')]}-            (cdcl' (+ count 1) (+ stage 1) vars cnf {<Guessed [g (+ stage 1)]> @trail'}))]}))))+cdcl vars cnf := cdcl' 0 0 (initVars vars) (toCnf cnf) [] -(define $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} {-8 4 7} {-8 -9 4} {7 17 -15} {12 -7 -14} {-10 -11 8} {2 -15 -11} {9 6 1} {-11 20 -17} {9 -15 13} {12 -7 -17} {-18 -2 20} {20 12 4} {19 11 14} {-16 18 -4} {-1 -17 -19} {-13 15 10} {-12 -14 -13} {12 -14 -7} {-7 16 10} {6 10 7} {20 14 -16} {-19 17 11} {-7 1 -20} {-5 12 15} {-4 -9 -13} {12 -11 -7} {-5 19 -8} {1 16 17} {20 -14 -15} {13 -4 10} {14 7 10} {-5 9 20} {10 1 -19} {-16 -15 -1} {16 3 -11} {-15 -10 4} {4 -15 -3} {-10 -16 11} {-8 12 -5} {14 -6 12} {1 6 11} {-13 -5 -1} {-7 -2 12} {1 -20 19} {-2 -13 -8} {15 18 4} {-11 14 9} {-6 -15 -2} {5 -12 -15} {-6 17 5} {-13 5 -19} {20 -1 14} {9 -17 15} {-5 19 -18} {-12 8 -10} {-18 14 -4} {15 -9 13} {9 -5 -1} {10 -19 -14} {20 9 4} {-9 -2 19} {-5 13 -17} {2 -10 -18} {-18 3 11} {7 -9 17} {-15 -6 -3} {-2 3 -13} {12 3 -2} {-2 -3 17} {20 -15 -16} {-5 -17 -19} {-20 -18 11} {-9 1 -5} {-19 9 17} {12 -2 17} {4 -16 -5}})+cdcl' count stage vars cnf trail :=+  let (cnf', trail') := unitPropagate stage cnf trail+   in matchDFS cnf' as multiset (multiset literal, multiset literal) with+        | [] -> True+        | ([], $cc) :: _ ->+          matchDFS trail' as list assignment with+            | _ ++ guessed ($l, #stage) :: $trail'' ->+              let (s, lc) := learn+                               stage+                               (map (\l -> (l, getStage l trail')) cc)+                               trail'+                  trail''' := backjump s trail''+               in cdcl'+                    (count + 1)+                    s+                    (addVars lc vars)+                    ((lc, lc) :: cnf)+                    trail'''+            | _ -> False+        | _ ->+          let g := guess vars trail'+           in cdcl'+                (count + 1)+                (stage + 1)+                vars+                cnf+                (Guessed (g, stage + 1) :: trail') -(define $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} {-13 -46 -41} {21 -4 9} {12 48 10} {24 23 15} {-8 -41 -43} {-44 -2 -35} {-27 18 31} {47 35 6} {-11 -27 41} {-33 -47 -45} {-16 36 -37} {27 -46 2} {15 -28 10} {-38 46 -39} {-33 -4 24} {-12 -45 50} {-32 -21 -15} {8 42 24} {30 -49 4} {45 -9 28} {-33 -47 -1} {1 27 -16} {-11 -17 -35} {-42 -15 45} {-19 -27 30} {3 28 12} {48 -11 -33} {-6 37 -9} {-37 13 -7} {-2 26 16} {46 -24 -38} {-13 -24 -8} {-36 -42 -21} {-37 -19 3} {-31 -50 35} {-7 -26 29} {-42 -45 29} {33 25 -6} {-45 -5 7} {-7 28 -6} {-48 31 -11} {32 16 -37} {-24 48 1} {18 -46 23} {-30 -50 48} {-21 39 -2} {24 47 42} {-36 30 4} {-5 28 -1} {-47 32 -42} {16 37 -22} {-43 42 -34} {-40 39 -20} {-49 29 6} {-41 -3 39} {-16 -12 43} {24 22 3} {47 -45 43} {45 -37 46} {-9 26 5} {-3 23 -13} {5 -34 13} {12 39 13} {22 50 37} {19 9 46} {-24 8 -27} {-28 7 21} {8 -25 50} {20 50 4} {27 36 13} {26 31 -25} {39 -44 -32} {-20 41 -10} {49 -28 35} {1 44 34} {39 35 -11} {-50 -42 -7} {-24 7 47} {-13 5 -48} {-9 -20 -23} {2 17 -19} {11 23 21} {-45 30 15} {11 26 -24} {38 33 -13} {44 -27 -7} {41 49 2} {-18 12 -37} {-2 12 -26} {-19 7 32} {-22 11 33} {8 12 -20} {16 40 -48} {-2 -24 -11} {26 -17 37} {-14 -19 46} {5 47 36} {-29 -9 19} {32 4 28} {-34 20 -46} {-4 -36 -13} {-15 -37 45} {-21 29 23} {-6 -40 7} {-42 31 -29} {-36 24 31} {-45 -37 -1} {3 -6 -29} {-28 -50 27} {44 26 5} {-17 -48 49} {12 -40 -7} {-12 31 -48} {27 32 -42} {-27 -10 1} {6 -49 10} {-24 8 43} {23 31 1} {11 -47 38} {-28 26 -13} {-40 12 -42} {-3 39 46} {17 41 46} {23 21 13} {-14 -1 -38} {20 18 6} {-50 20 -9} {10 -32 -18} {-21 49 -34} {44 23 -35} {40 -19 34} {-1 6 -12} {6 -2 -7} {32 -20 34} {-12 43 -29} {24 2 -49} {10 -4 40} {11 5 12} {-3 47 -31} {43 -23 21} {-41 -36 -50} {-8 -42 -24} {39 45 7} {7 37 -45} {41 40 8} {-50 -10 -8} {-5 -39 -14} {-22 -24 -43} {-36 40 35} {17 49 41} {-32 7 24} {-30 -8 -9} {-41 -13 -10} {31 26 -33} {17 -22 -39} {-21 28 3} {-14 46 23} {29 16 19} {42 -32 -44} {-24 10 23} {-1 -32 -21} {-8 -44 -39} {39 11 9} {19 14 -46} {46 44 -42} {37 23 -29} {32 25 20} {14 -43 -12} {-36 -18 46} {14 -26 -10} {-2 -30 5} {6 -18 46} {-26 2 -44} {20 -8 -11} {-31 3 16} {-22 -9 39} {-49 44 -42} {-45 -44 31} {-31 50 -11} {-32 -46 2} {-6 -7 17} {19 -32 48} {39 20 -10} {-22 -37 38} {-31 9 -48} {40 12 7} {-24 -4 9} {-22 49 33} {-12 43 10} {25 -30 -10} {46 47 31} {13 27 -7} {-45 32 -35} {-50 34 9} {2 34 30} {3 16 2} {-18 45 -12} {33 37 10} {43 7 -18} {-22 44 -19} {-31 -27 -42} {-3 -40 8} {-23 -31 38}})+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],+   [-8, 4, 7], [-8, -9, 4], [7, 17, -15], [12, -7, -14], [-10, -11, 8],+   [2, -15, -11], [9, 6, 1], [-11, 20, -17], [9, -15, 13], [12, -7, -17],+   [-18, -2, 20], [20, 12, 4], [19, 11, 14], [-16, 18, -4], [-1, -17, -19],+   [-13, 15, 10], [-12, -14, -13], [12, -14, -7], [-7, 16, 10], [6, 10, 7],+   [20, 14, -16], [-19, 17, 11], [-7, 1, -20], [-5, 12, 15], [-4, -9, -13],+   [12, -11, -7], [-5, 19, -8], [1, 16, 17], [20, -14, -15], [13, -4, 10],+   [14, 7, 10], [-5, 9, 20], [10, 1, -19], [-16, -15, -1], [16, 3, -11],+   [-15, -10, 4], [4, -15, -3], [-10, -16, 11], [-8, 12, -5], [14, -6, 12],+   [1, 6, 11], [-13, -5, -1], [-7, -2, 12], [1, -20, 19], [-2, -13, -8],+   [15, 18, 4], [-11, 14, 9], [-6, -15, -2], [5, -12, -15], [-6, 17, 5],+   [-13, 5, -19], [20, -1, 14], [9, -17, 15], [-5, 19, -18], [-12, 8, -10],+   [-18, 14, -4], [15, -9, 13], [9, -5, -1], [10, -19, -14], [20, 9, 4],+   [-9, -2, 19], [-5, 13, -17], [2, -10, -18], [-18, 3, 11], [7, -9, 17],+   [-15, -6, -3], [-2, 3, -13], [12, 3, -2], [-2, -3, 17], [20, -15, -16],+   [-5, -17, -19], [-20, -18, 11], [-9, 1, -5], [-19, 9, 17], [12, -2, 17],+   [4, -16, -5]] -(assert-equal "cdcl" (cdcl (between 1 20) problem20) #t) ; 2.798-;(assert-equal "cdcl" (cdcl (between 1 50) problem50) #f) ; 1:10.74+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],+   [-13, -46, -41], [21, -4, 9], [12, 48, 10], [24, 23, 15], [-8, -41, -43],+   [-44, -2, -35], [-27, 18, 31], [47, 35, 6], [-11, -27, 41], [-33, -47, -45],+   [-16, 36, -37], [27, -46, 2], [15, -28, 10], [-38, 46, -39], [-33, -4, 24],+   [-12, -45, 50], [-32, -21, -15], [8, 42, 24], [30, -49, 4], [45, -9, 28],+   [-33, -47, -1], [1, 27, -16], [-11, -17, -35], [-42, -15, 45],+   [-19, -27, 30], [3, 28, 12], [48, -11, -33], [-6, 37, -9], [-37, 13, -7],+   [-2, 26, 16], [46, -24, -38], [-13, -24, -8], [-36, -42, -21], [-37, -19, 3],+   [-31, -50, 35], [-7, -26, 29], [-42, -45, 29], [33, 25, -6], [-45, -5, 7],+   [-7, 28, -6], [-48, 31, -11], [32, 16, -37], [-24, 48, 1], [18, -46, 23],+   [-30, -50, 48], [-21, 39, -2], [24, 47, 42], [-36, 30, 4], [-5, 28, -1],+   [-47, 32, -42], [16, 37, -22], [-43, 42, -34], [-40, 39, -20], [-49, 29, 6],+   [-41, -3, 39], [-16, -12, 43], [24, 22, 3], [47, -45, 43], [45, -37, 46],+   [-9, 26, 5], [-3, 23, -13], [5, -34, 13], [12, 39, 13], [22, 50, 37],+   [19, 9, 46], [-24, 8, -27], [-28, 7, 21], [8, -25, 50], [20, 50, 4],+   [27, 36, 13], [26, 31, -25], [39, -44, -32], [-20, 41, -10], [49, -28, 35],+   [1, 44, 34], [39, 35, -11], [-50, -42, -7], [-24, 7, 47], [-13, 5, -48],+   [-9, -20, -23], [2, 17, -19], [11, 23, 21], [-45, 30, 15], [11, 26, -24],+   [38, 33, -13], [44, -27, -7], [41, 49, 2], [-18, 12, -37], [-2, 12, -26],+   [-19, 7, 32], [-22, 11, 33], [8, 12, -20], [16, 40, -48], [-2, -24, -11],+   [26, -17, 37], [-14, -19, 46], [5, 47, 36], [-29, -9, 19], [32, 4, 28],+   [-34, 20, -46], [-4, -36, -13], [-15, -37, 45], [-21, 29, 23], [-6, -40, 7],+   [-42, 31, -29], [-36, 24, 31], [-45, -37, -1], [3, -6, -29], [-28, -50, 27],+   [44, 26, 5], [-17, -48, 49], [12, -40, -7], [-12, 31, -48], [27, 32, -42],+   [-27, -10, 1], [6, -49, 10], [-24, 8, 43], [23, 31, 1], [11, -47, 38],+   [-28, 26, -13], [-40, 12, -42], [-3, 39, 46], [17, 41, 46], [23, 21, 13],+   [-14, -1, -38], [20, 18, 6], [-50, 20, -9], [10, -32, -18], [-21, 49, -34],+   [44, 23, -35], [40, -19, 34], [-1, 6, -12], [6, -2, -7], [32, -20, 34],+   [-12, 43, -29], [24, 2, -49], [10, -4, 40], [11, 5, 12], [-3, 47, -31],+   [43, -23, 21], [-41, -36, -50], [-8, -42, -24], [39, 45, 7], [7, 37, -45],+   [41, 40, 8], [-50, -10, -8], [-5, -39, -14], [-22, -24, -43], [-36, 40, 35],+   [17, 49, 41], [-32, 7, 24], [-30, -8, -9], [-41, -13, -10], [31, 26, -33],+   [17, -22, -39], [-21, 28, 3], [-14, 46, 23], [29, 16, 19], [42, -32, -44],+   [-24, 10, 23], [-1, -32, -21], [-8, -44, -39], [39, 11, 9], [19, 14, -46],+   [46, 44, -42], [37, 23, -29], [32, 25, 20], [14, -43, -12], [-36, -18, 46],+   [14, -26, -10], [-2, -30, 5], [6, -18, 46], [-26, 2, -44], [20, -8, -11],+   [-31, 3, 16], [-22, -9, 39], [-49, 44, -42], [-45, -44, 31], [-31, 50, -11],+   [-32, -46, 2], [-6, -7, 17], [19, -32, 48], [39, 20, -10], [-22, -37, 38],+   [-31, 9, -48], [40, 12, 7], [-24, -4, 9], [-22, 49, 33], [-12, 43, 10],+   [25, -30, -10], [46, 47, 31], [13, 27, -7], [-45, 32, -35], [-50, 34, 9],+   [2, 34, 30], [3, 16, 2], [-18, 45, -12], [33, 37, 10], [43, 7, -18],+   [-22, 44, -19], [-31, -27, -42], [-3, -40, 8], [-23, -31, 38]]++assertEqual "cdcl" (cdcl (between 1 20) problem20) True -- 2.798+-- assertEqual "cdcl" (cdcl (between 1 50) problem50) False -- 1:10.74
sample/sat/dp.egi view
@@ -1,41 +1,45 @@-(define $delete-literal-  (lambda [$l $cnf]-    (map (lambda [$c] (match-all c (multiset integer)-                        [<cons (and !,l $x) _> x]))-         cnf)))+--+-- This file has been auto-generated by egison-translator.+-- -(define $delete-clauses-with-  (lambda [$l $cnf]-    (match-all cnf (multiset (multiset integer))-      [<cons (& !<cons ,l _> $c) _> c])))+deleteLiteral l cnf :=+  map+    (\c -> matchAll c as multiset integer with+        | ((!#l) & $x) :: _ -> x)+    cnf -(define $assign-true-  (lambda [$l $cnf]-    (delete-literal (neg l) (delete-clauses-with l cnf))))+deleteClausesWith l cnf :=+  matchAll cnf as multiset (multiset integer) with+    | ((!(#l :: _)) & $c) :: _ -> c -(define $resolve-on-  (lambda [$v $cnf]-    (match-all cnf (multiset (multiset integer))-      [{<cons <cons ,v (& # $xs)>-         <cons <cons ,(neg v) (and # $ys)>-          _>>-        ![<cons $l _> <cons ,(neg l) _>]}-       (unique {@xs @ys})])))+assignTrue l cnf := deleteLiteral (neg l) (deleteClausesWith l cnf) -(define $dp-  (lambda [$vars $cnf]-    (match [vars cnf] [(multiset integer) (multiset (multiset integer))]-      {[[_ <nil>] #t]-       [[_ <cons <nil> _>] #f]-       [[_ <cons <cons $l <nil>> _>] (dp (delete (abs l) vars) (assign-true l cnf))]-       [[<cons $v $vs> !<cons <cons ,(neg v) _> _>] (dp vs (assign-true v cnf))]-       [[<cons $v $vs> !<cons <cons ,v _> _>] (dp vs (assign-true (neg v) cnf))]-       [[<cons $v $vs> _] (dp vs {@(resolve-on v cnf) @(delete-clauses-with v (delete-clauses-with (neg v) cnf))})]})))+resolveOn v cnf :=+  matchAll cnf as multiset (multiset integer) with+    | {(#v :: (@ & $xs)) :: (#(neg v) :: (@ & $ys)) :: _,+       !( $l :: _, #(neg l) :: _ )} ->+      unique (xs ++ ys) -(dp {1} {{1}}) ; #t-(dp {1} {{1} {-1}}) ; #f-(dp {1 2 3} {{1 2} {-1 3} {1 -3}}) ; #t-(dp {1 2} {{1 2} {-1 -2} {1 -2}}) ; #t-(dp {1 2} {{1 2} {-1 -2} {1 -2} {-1 2}}) ; #f-(dp {1 2 3 4 5} {{-1 -2 3} {-1 -2 -3} {1 2 3 4} {-4 -2 3} {5 1 2 -3} {-3 1 -5} {1 -2 3 4} {1 -2 -3 5}}) ; #t-(dp {1 2} {{-1 -2} {1}}) ; #t+dp vars cnf :=+  match (vars, cnf) as (multiset integer, multiset (multiset integer)) with+  | (_, []) -> True+  | (_, [] :: _) -> False+  -- 1-literal rule+  | (_, [$l] :: _) -> dp (delete (abs l) vars) (assignTrue l cnf)+  -- pure literal rule (positive)+  | ($v :: $vs, !((#(neg v) :: _) :: _)) -> dp vs (assignTrue v cnf)+  -- pure literal rule (negative)+  | ($v :: $vs, !((#v :: _) :: _)) -> dp vs (assignTrue (neg v) cnf)+  -- otherwise+  | ($v :: $vs, _) ->+    dp vs+       ((resolveOn v cnf) ++ (deleteClausesWith v (deleteClausesWith (neg v) cnf)))++dp [1] [[1]]+dp [1] [[1], [-1]]+dp [1, 2, 3] [[1, 2], [-1, 3], [1, -3]]+dp [1, 2] [[1, 2], [-1, -2], [1, -2]]+dp [1, 2] [[1, 2], [-1, -2], [1, -2], [-1, 2]]+dp [1, 2, 3, 4, 5]+   [[-1, -2, 3], [-1, -2, -3], [1, 2, 3, 4], [-4, -2, 3], [5, 1, 2, -3], [-3, 1, -5], [1, -2, 3, 4], [1, -2, -3, 5]]+dp [1, 2] [[-1, -2], [1]]
− sample/sat/dp2.egi 
@@ -1,43 +0,0 @@-(define $delete-literals-  (lambda [$ls $cnf]-    (map (lambda [$c] (match-all [c ls] [(multiset integer) (multiset integer)]-                        [[<cons $l _> !<cons ,l _>] l]))-         cnf)))--(define $delete-clauses-with-  (lambda [$ls $cnf]-    (match-all [ls cnf] [(multiset integer) (multiset (multiset integer))]-      [{[# <cons (& # $c) _>]-        ![<cons $l _> <cons ,l _>]}-       c])))--(define $assign-true-  (lambda [$l $cnf]-    (delete-literals {(neg l)} (delete-clauses-with {l} cnf))))--(define $resolve-on-  (lambda [$v $cnf]-    (match-all cnf (multiset (multiset integer))-      [{<cons <cons ,v (& # $xs)>-         <cons <cons ,(neg v) (and # $ys)>-          _>>-        ![<cons $l _> <cons ,(neg l) _>]}-       (unique {@xs @ys})])))--(define $dp-  (lambda [$vars $cnf]-    (match [vars cnf] [(multiset integer) (multiset (multiset integer))]-      {[[_ <nil>] #t]-       [[_ <cons <nil> _>] #f]-       [[_ <cons <cons $l <nil>> _>] (dp (delete (abs l) vars) (assign-true l cnf))]-       [[<cons $v $vs> !<cons <cons ,(neg v) _> _>] (dp vs (assign-true v cnf))]-       [[<cons $v $vs> !<cons <cons ,v _> _>] (dp vs (assign-true (neg v) cnf))]-       [[<cons $v $vs> _] (dp vs {@(resolve-on v cnf) @(delete-clauses-with {v (neg v)} cnf)})]})))--(dp {1} {{1}}) ; #t-(dp {1} {{1} {-1}}) ; #f-(dp {1 2 3} {{1 2} {-1 3} {1 -3}}) ; #t-(dp {1 2} {{1 2} {-1 -2} {1 -2}}) ; #t-(dp {1 2} {{1 2} {-1 -2} {1 -2} {-1 2}}) ; #f-(dp {1 2 3 4 5} {{-1 -2 3} {-1 -2 -3} {1 2 3 4} {-4 -2 3} {5 1 2 -3} {-3 1 -5} {1 -2 3 4} {1 -2 -3 5}}) ; #t-(dp {1 2} {{-1 -2} {1}}) ; #t
− sample/sat/dp3.egi 
@@ -1,53 +0,0 @@-(define $delete-literal-  (lambda [$l $cnf]-    (map (lambda [$c] (match-all c (multiset integer)-                        [<cons (and !,l $x) _> x]))-         cnf)))--(define $delete-clauses-with-  (lambda [$l $cnf]-    (match-all cnf (multiset (multiset integer))-      [<cons (& !<cons ,l _> $c) _> c])))--(define $assign-true-  (lambda [$l $cnf]-    (delete-literal (neg l) (delete-clauses-with l cnf))))--(define $resolve-on-  (lambda [$v $cnf]-    (match-all cnf (multiset (multiset integer))-      [{<cons <cons ,v (& # $xs)>-         <cons <cons ,(neg v) (and # $ys)>-          _>>-        ![<cons $l _> <cons ,(neg l) _>]}-       (unique {@xs @ys})])))--(define $resolution-blowup-  (lambda [$v $cnf]-    (let {[$m (length (match-all cnf (multiset (multiset integer)) [<cons <cons ,v _> _> v]))]-          [$n (length (match-all cnf (multiset (multiset integer)) [<cons <cons ,(neg v) _> _> v]))]}-      (- (* m n) (+ m n)))))--(define $dp-  (lambda [$vars $cnf]-    (match [vars cnf] [(multiset integer) (multiset (multiset integer))]-      {[[_ <nil>] #t]-       [[_ <cons <nil> _>] #f]-       [[_ <cons <cons $l <nil>> _>]-        (dp (delete (abs l) vars) (assign-true l cnf))]-       [[<cons $v $vs> !<cons <cons ,(neg v) _> _>]-        (dp vs (assign-true v cnf))]-       [[<cons $v $vs> !<cons <cons ,v _> _>]-        (dp vs (assign-true (neg v) cnf))]-       [[_ _]-        (let {[$v (minimize 1#(resolution-blowup %1 cnf) vars)]}-          (dp (delete v vars) {@(resolve-on v cnf)-                               @(delete-clauses-with v (delete-clauses-with (neg v) cnf))}))]})))--(dp {1} {{1}}) ; #t-(dp {1} {{1} {-1}}) ; #f-(dp {1 2 3} {{1 2} {-1 3} {1 -3}}) ; #t-(dp {1 2} {{1 2} {-1 -2} {1 -2}}) ; #t-(dp {1 2} {{1 2} {-1 -2} {1 -2} {-1 2}}) ; #f-(dp {1 2 3 4 5} {{-1 -2 3} {-1 -2 -3} {1 2 3 4} {-4 -2 3} {5 1 2 -3} {-3 1 -5} {1 -2 3 4} {1 -2 -3 5}}) ; #t-(dp {1 2} {{-1 -2} {1}}) ; #t
− sample/sat/dpll.egi 
@@ -1,363 +0,0 @@-(define $delete-literal-  (lambda [$l $cnf]-    (map (lambda [$c] (match-all c (multiset integer)-                        [<cons (and !,l $x) _> x]))-         cnf)))--(define $delete-clauses-with-  (lambda [$l $cnf]-    (match-all cnf (multiset (multiset integer))-      [<cons (& !<cons ,l _> $c) _> c])))--(define $assign-true-  (lambda [$l $cnf]-    (delete-literal (neg l) (delete-clauses-with l cnf))))--(define $assignment-  (algebraic-data-matcher-    {<deduced integer> <guessed integer something something>}))--(define $dpll'-  (lambda [$vars $cnf $trail]-    (match [vars cnf] [(multiset integer) (multiset (multiset integer))]-      {[[_ <nil>] #t]-       [[_ <cons <nil> _>]-        (match (debug trail) (list assignment)-          {[<join _ <cons <guessed $l $vars' $cnf'> $trail'>>-            (dpll' vars' (assign-true (neg l) cnf') {<Deduced (neg l)> @trail'})]-           [_ #f]})]-       [[_ <cons <cons $l <nil>> _>] (dpll' (delete (abs l) vars) (assign-true l cnf) {<Deduced l> @trail})]-       [[<cons $v $vs> !<cons <cons ,(neg v) _> _>] (dpll' vs (assign-true v cnf) {<Deduced v> @trail})]-       [[<cons $v $vs> !<cons <cons ,v _> _>] (dpll' vs (assign-true (neg v) cnf) {<Deduced (neg v)> @trail})]-       [[<cons $v $vs> _] (dpll' vs (assign-true v cnf) {<Guessed v vs cnf> @trail})]-       })))--(define $dpll-  (lambda [$vars $cnf]-    (dpll' vars cnf {})))--;"dpll start"-(dpll {1} {{1}}) ; #t-(dpll {1} {{1} {-1}}) ; #f-;(dpll {1 2 3} {{1 2} {-1 3} {1 -3}}) ; #t-;(dpll {1 2} {{1 2} {-1 -2} {1 -2}}) ; #t-;(dpll {1 2} {{1 2} {-1 -2} {1 -2} {-1 2}}) ; #f-;(dpll {1 2 3 4 5} {{-1 -2 3} {-1 -2 -3} {1 2 3 4} {-4 -2 3} {5 1 2 -3} {-3 1 -5} {1 -2 3 4} {1 -2 -3 5}}) ; #f-;(dpll {1 2} {{-1 -2} {1}}) ; #t-;"dpll end"--(define $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}-   {-8 4 7}-   {-8 -9 4}-   {7 17 -15}-   {12 -7 -14}-   {-10 -11 8}-   {2 -15 -11}-   {9 6 1}-   {-11 20 -17}-   {9 -15 13}-   {12 -7 -17}-   {-18 -2 20}-   {20 12 4}-   {19 11 14}-   {-16 18 -4}-   {-1 -17 -19}-   {-13 15 10}-   {-12 -14 -13}-   {12 -14 -7}-   {-7 16 10}-   {6 10 7}-   {20 14 -16}-   {-19 17 11}-   {-7 1 -20}-   {-5 12 15}-   {-4 -9 -13}-   {12 -11 -7}-   {-5 19 -8}-   {1 16 17}-   {20 -14 -15}-   {13 -4 10}-   {14 7 10}-   {-5 9 20}-   {10 1 -19}-   {-16 -15 -1}-   {16 3 -11}-   {-15 -10 4}-   {4 -15 -3}-   {-10 -16 11}-   {-8 12 -5}-   {14 -6 12}-   {1 6 11}-   {-13 -5 -1}-   {-7 -2 12}-   {1 -20 19}-   {-2 -13 -8}-   {15 18 4}-   {-11 14 9}-   {-6 -15 -2}-   {5 -12 -15}-   {-6 17 5}-   {-13 5 -19}-   {20 -1 14}-   {9 -17 15}-   {-5 19 -18}-   {-12 8 -10}-   {-18 14 -4}-   {15 -9 13}-   {9 -5 -1}-   {10 -19 -14}-   {20 9 4}-   {-9 -2 19}-   {-5 13 -17}-   {2 -10 -18}-   {-18 3 11}-   {7 -9 17}-   {-15 -6 -3}-   {-2 3 -13}-   {12 3 -2}-   {-2 -3 17}-   {20 -15 -16}-   {-5 -17 -19}-   {-20 -18 11}-   {-9 1 -5}-   {-19 9 17}-   {12 -2 17}-   {4 -16 -5}})--(define $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}-   {-13 -46 -41}-   {21 -4 9}-   {12 48 10}-   {24 23 15}-   {-8 -41 -43}-   {-44 -2 -35}-   {-27 18 31}-   {47 35 6}-   {-11 -27 41}-   {-33 -47 -45}-   {-16 36 -37}-   {27 -46 2}-   {15 -28 10}-   {-38 46 -39}-   {-33 -4 24}-   {-12 -45 50}-   {-32 -21 -15}-   {8 42 24}-   {30 -49 4}-   {45 -9 28}-   {-33 -47 -1}-   {1 27 -16}-   {-11 -17 -35}-   {-42 -15 45}-   {-19 -27 30}-   {3 28 12}-   {48 -11 -33}-   {-6 37 -9}-   {-37 13 -7}-   {-2 26 16}-   {46 -24 -38}-   {-13 -24 -8}-   {-36 -42 -21}-   {-37 -19 3}-   {-31 -50 35}-   {-7 -26 29}-   {-42 -45 29}-   {33 25 -6}-   {-45 -5 7}-   {-7 28 -6}-   {-48 31 -11}-   {32 16 -37}-   {-24 48 1}-   {18 -46 23}-   {-30 -50 48}-   {-21 39 -2}-   {24 47 42}-   {-36 30 4}-   {-5 28 -1}-   {-47 32 -42}-   {16 37 -22}-   {-43 42 -34}-   {-40 39 -20}-   {-49 29 6}-   {-41 -3 39}-   {-16 -12 43}-   {24 22 3}-   {47 -45 43}-   {45 -37 46}-   {-9 26 5}-   {-3 23 -13}-   {5 -34 13}-   {12 39 13}-   {22 50 37}-   {19 9 46}-   {-24 8 -27}-   {-28 7 21}-   {8 -25 50}-   {20 50 4}-   {27 36 13}-   {26 31 -25}-   {39 -44 -32}-   {-20 41 -10}-   {49 -28 35}-   {1 44 34}-   {39 35 -11}-   {-50 -42 -7}-   {-24 7 47}-   {-13 5 -48}-   {-9 -20 -23}-   {2 17 -19}-   {11 23 21}-   {-45 30 15}-   {11 26 -24}-   {38 33 -13}-   {44 -27 -7}-   {41 49 2}-   {-18 12 -37}-   {-2 12 -26}-   {-19 7 32}-   {-22 11 33}-   {8 12 -20}-   {16 40 -48}-   {-2 -24 -11}-   {26 -17 37}-   {-14 -19 46}-   {5 47 36}-   {-29 -9 19}-   {32 4 28}-   {-34 20 -46}-   {-4 -36 -13}-   {-15 -37 45}-   {-21 29 23}-   {-6 -40 7}-   {-42 31 -29}-   {-36 24 31}-   {-45 -37 -1}-   {3 -6 -29}-   {-28 -50 27}-   {44 26 5}-   {-17 -48 49}-   {12 -40 -7}-   {-12 31 -48}-   {27 32 -42}-   {-27 -10 1}-   {6 -49 10}-   {-24 8 43}-   {23 31 1}-   {11 -47 38}-   {-28 26 -13}-   {-40 12 -42}-   {-3 39 46}-   {17 41 46}-   {23 21 13}-   {-14 -1 -38}-   {20 18 6}-   {-50 20 -9}-   {10 -32 -18}-   {-21 49 -34}-   {44 23 -35}-   {40 -19 34}-   {-1 6 -12}-   {6 -2 -7}-   {32 -20 34}-   {-12 43 -29}-   {24 2 -49}-   {10 -4 40}-   {11 5 12}-   {-3 47 -31}-   {43 -23 21}-   {-41 -36 -50}-   {-8 -42 -24}-   {39 45 7}-   {7 37 -45}-   {41 40 8}-   {-50 -10 -8}-   {-5 -39 -14}-   {-22 -24 -43}-   {-36 40 35}-   {17 49 41}-   {-32 7 24}-   {-30 -8 -9}-   {-41 -13 -10}-   {31 26 -33}-   {17 -22 -39}-   {-21 28 3}-   {-14 46 23}-   {29 16 19}-   {42 -32 -44}-   {-24 10 23}-   {-1 -32 -21}-   {-8 -44 -39}-   {39 11 9}-   {19 14 -46}-   {46 44 -42}-   {37 23 -29}-   {32 25 20}-   {14 -43 -12}-   {-36 -18 46}-   {14 -26 -10}-   {-2 -30 5}-   {6 -18 46}-   {-26 2 -44}-   {20 -8 -11}-   {-31 3 16}-   {-22 -9 39}-   {-49 44 -42}-   {-45 -44 31}-   {-31 50 -11}-   {-32 -46 2}-   {-6 -7 17}-   {19 -32 48}-   {39 20 -10}-   {-22 -37 38}-   {-31 9 -48}-   {40 12 7}-   {-24 -4 9}-   {-22 49 33}-   {-12 43 10}-   {25 -30 -10}-   {46 47 31}-   {13 27 -7}-   {-45 32 -35}-   {-50 34 9}-   {2 34 30}-   {3 16 2}-   {-18 45 -12}-   {33 37 10}-   {43 7 -18}-   {-22 44 -19}-   {-31 -27 -42}-   {-3 -40 8}-   {-23 -31 38}})--;(dpll (between 1 20) problem50) ;-(dpll (between 1 50) problem50) ; 3:45.34
− sample/tail-recursion.egi 
@@ -1,10 +0,0 @@-(define $f (lambda [$x]-             (if (eq? x 0)-               (f (+ x 1))-               (f (- x 1)))))--(define $g (lambda [$x] (h (+ x 1))))-(define $h (lambda [$x] (g (- x 1))))--(f 0)-;(g 0)
− sample/tak.egi 
@@ -1,21 +0,0 @@-(define $tarai-  (lambda [$x $y $z]-    (if (lte? x y)-      y-      (tarai (tarai (- x 1) y z)-             (tarai (- y 1) z x)-             (tarai (- z 1) x y)))))--(test (tarai 1 1 1))-(test (tarai 4 2 1))--(define $tak-  (lambda [$x $y $z]-    (if (lte? x y)-      z-      (tak (tak (- x 1) y z)-           (tak (- y 1) z x)-           (tak (- z 1) x y)))))--(test (tak 1 1 1))-(test (tak 4 2 1))
− sample/tree.egi 
@@ -1,89 +0,0 @@-;;;-;;;-;;; Tree demonstration-;;;-;;;--;;-;; Matcher definition-;;-(define $tree-  (lambda [$a $b]-    (matcher-      {[,$val []-        {[$tgt (match [val tgt] [(tree a b) (tree a b)]-                 {[[<lnode $x $ts> <lnode ,x ,ts>] {[]}]-                  [[_ _] {}]})]}]-       [<leaf $> b-        {[<Leaf $x> {x}]-         [_ {}]}]-       [<lnode $ $> [a (list (tree a b))] ; Node whose children are seen as a list.-        {[<Node $x $ts> {[x ts]}]-         [_ {}]}]-       [<mnode $ $> [a (multiset (tree a b))] ; Node whose children are seen as a multiset.-        {[<Node $x $ts> {[x ts]}]-         [_ {}]}]-       [<descendant $> [(tree a b)]-        {[$t (match-all t (tree a b)-               [(loop $i [1 _] <mnode _ <cons ... _>> $x) x])]}]-       [$ [something]-        {[$tgt {tgt}]}]-       })))--;;-;; Demonstration code-;;-(define $tree-data-  <Node "Programming language"-    {<Node "Pattern-matching oriented"-       {<Leaf "Egison">}>-     <Node "Functional language"-       {<Node "Strictly typed"-          {<Leaf "OCaml">-           <Leaf "Haskell">-           <Leaf "Curry">-           <Leaf "Coq">-           }>-        <Node "Dynamically typed"-          {<Leaf "Egison">-           <Leaf "Lisp">-           <Leaf "Scheme">-           <Leaf "Clojure">-           }>-        }>-     <Node "Logic programming"-       {<Leaf "Prolog">-        <Leaf "LiLFeS">-        <Leaf "Curry">-        }>-     <Node "Object oriented"-       {<Leaf "C++">-        <Leaf "Java">-        <Leaf "Ruby">-        <Leaf "Python">-        <Leaf "OCaml">-        }>-     }>)---; All langauges-(test (unique/m string (match-all tree-data (tree string string)-                         [<descendant <leaf $x>> x])))-        -; All langauges that belongs to Functional language-(test (unique/m string (match-all tree-data (tree string string)-                         [<descendant <mnode ,"Functional language" <cons <descendant <leaf $x>> _>>> x])))-        -; All langauges that belongs more than two categories-(test (unique/m string (match-all tree-data (tree string string)-                         [<mnode _ <cons <descendant <leaf $x>>-                                         <cons <descendant <leaf ,x>>-                                               _>>>-                          x])))--; All categories that Egison belongs-(test (match-all tree-data (tree string string)-        [(loop $i [1 $n]-               <mnode $c_i <cons ... _>>-               <leaf ,"Egison">)-         c]))
− sample/triangle.egi 
@@ -1,26 +0,0 @@-(define $points-  {[3 1] [4 5] [7 7] [8 1] [1 9] [3 8] [3 1]})--(define $on-a-line?-  (match-lambda [[integer integer] [integer integer] [integer integer]]-    {[[[$x1 $y1] [$x2 $y2] [$x3 $y3]]-      (eq? (abs (* (- y2 y1) (- x3 x1)))-           (abs (* (- y3 y1) (- x2 x1))))]}))--; Enumerate triangles-(match-all points (list [integer integer])-  [<join _ <cons $p1-    <join _ <cons $p2-     <join _ <cons (& !?(on-a-line? p1 p2 $) $p3)-       _>>>>>>-   [p1 p2 p3]])-;=>{[[3 1] [4 5] [7 7]] [[3 1] [4 5] [8 1]] [[3 1] [7 7] [8 1]] [[4 5] [7 7] [8 1]] [[3 1] [7 7] [1 9]] [[3 1] [8 1] [1 9]] [[4 5] [7 7] [1 9]] [[4 5] [8 1] [1 9]] [[7 7] [8 1] [1 9]] [[3 1] [4 5] [3 8]] [[3 1] [7 7] [3 8]] [[3 1] [8 1] [3 8]] [[3 1] [1 9] [3 8]] [[4 5] [7 7] [3 8]] [[4 5] [8 1] [3 8]] [[4 5] [1 9] [3 8]] [[7 7] [8 1] [3 8]] [[7 7] [1 9] [3 8]] [[8 1] [1 9] [3 8]] [[4 5] [7 7] [3 1]] [[4 5] [8 1] [3 1]] [[4 5] [1 9] [3 1]] [[4 5] [3 8] [3 1]] [[7 7] [8 1] [3 1]] [[7 7] [1 9] [3 1]] [[7 7] [3 8] [3 1]] [[8 1] [1 9] [3 1]] [[8 1] [3 8] [3 1]] [[1 9] [3 8] [3 1]]}--; Enumerate tiplets of points on a line-(match-all points (list [integer integer])-  [<join _ <cons $p1-    <join _ <cons $p2-     <join _ <cons (& ?(on-a-line? p1 p2 $) $p3)-       _>>>>>>-   [p1 p2 p3]])-;=>{[[3 1] [4 5] [1 9]] [[3 1] [4 5] [3 1]] [[3 1] [7 7] [3 1]] [[3 1] [8 1] [3 1]] [[3 1] [1 9] [3 1]] [[3 1] [3 8] [3 1]]}
− sample/unify.egi 
@@ -1,143 +0,0 @@-;;-;; Unification-;; - Main program is originally written by Yuichi Nishiwaki-;; - Utity functions are originally written by Momoko Hattori-;;--(define $term-  (matcher-    {[<var $> integer-      {[<Var $i> {i}]-       [_ {}]}]-     [<compound $ $> [string (list term)]-      {[<Compound $s $l> {[s l]}]-       [_ {}]}]-     [<unify ,$t $> something-      {[$s (match (unify t s) (maybe something)-             {[(just $σ) {σ}]-              [(nothing) {}]})]}]-     [<subterm $ $> [term something]-      {[$s (subterm s)]}]-     [$ something-      {[$tgt {tgt}]}]}))--(define $var (lambda [$n] <Var n>))--(define $app-  (cambda $xs-    (match xs (list something)-      {[<cons $x $xs> <Compound x xs>]})))--(define $occur-  (pattern-function [$v]-    (| <var v>-       <compound _ <join _ <cons (occur v) _>>>)))--(define $fv-  (match-all-lambda [term]-    {[(occur $v) v]}))--(define $tsubst-  (match-lambda [something term]-    {[[$σ <var $n>]-       (match σ (multiset [integer term])-         {[<cons [,n $t] _> t]-          [_ <Var n>]})]-     [[$σ <compound $f $xs>]-       <Compound f (map (tsubst σ $) xs)>]}))--(define $unify-  (match-lambda (unordered-pair term)-    {[[<var $x> <var ,x>]-      (Just {})]-     [[<var $x> (& $t !(occur ,x))]-      (Just {[x t]})]-     [[<compound $f $xs> <compound ,f $ys>]-      (unify-list xs ys)]-     [_ Nothing]}))--(define $unify-list-  (match-lambda [(list term) (list term)]-    {[[<nil> <nil>] (Just {})]-     [[<cons $x $xs> <cons $y $ys>]-      (match (unify x y) (maybe something)-       {[(nothing) Nothing]-        [(just $σ1)-         (match (unify-list (map (tsubst σ1 $) xs) (map (tsubst σ1 $) ys)) (maybe something)-           {[(nothing) Nothing]-            [(just $σ2) (Just {@σ1 @σ2})]})]})]-     [_ Nothing]}))--;;-;; Utility for tests-;;--; variables-(define $x (var 0))-(define $y (var 1))-(define $z (var 2))-(define $w (var 3))--; constants-(define $a (app "a"))-(define $b (app "b"))-(define $c (app "c"))-(define $d (app "d"))--; function-(define $f "f")-(define $g "g")-(define $h "h")--(define $show-σ-  (lambda [$σ]-    (S.concat {"{" (show-σ' σ) "}"})))--(define $show-σ'-  (match-lambda (list [something something])-    {[<nil> ""]-     [<cons [$v $t] <nil>>-      (S.concat {"[" (show-var v) ", " (show-term t) "]"})]-     [<cons [$v $t] $σ>-      (S.concat {"[" (show-var v) ", " (show-term t) "], " (show-σ' σ)})]}))--(define $show-var-  (match-lambda integer-    {[,0 "x"]-     [,1 "y"]-     [,2 "z"]-     [,3 "w"]-     }))--(define $show-term-  (match-lambda term-    {[<var ,0> "x"]-     [<var ,1> "y"]-     [<var ,2> "z"]-     [<var ,3> "w"]-     [<var $x> (S.concat {"x" (show x)})]-     [<compound $f ,{}> f]-     [<compound ,"+" <cons (& <compound ,"+" _> $x) <cons $y <nil>>>>-       (S.concat {"(" (show-term x) ") + " (show-term y)})]-     [<compound ,"+" <cons $x <cons $y <nil>>>>-       (S.concat {(show-term x) " + " (show-term y)})]-     [<compound ,"*" <cons (& <compound ,"*" _> $x) <cons $y <nil>>>>-       (S.concat {"(" (show-term x) ") * " (show-term y)})]-     [<compound ,"*" <cons $x <cons $y <nil>>>>-       (S.concat {(show-term x) " * " (show-term y)})]-     [<compound $f $xs>-       (S.concat {f "(" (S.intercalate ", " (map show-term xs)) ")"})]-    }))--;;-;; Test-;;--(show-σ (car (unify (app "+" a b) x)))-; "{[x, a + b]}"--(show-σ (car (unify x (app "+" y z))))-; "{[x, y + z]}"--(show-σ (car (unify (app f x (app g y z) (app h x)) (app f a w y))))-; "{[x, a], [w, g(y, z)], [y, h(a)]}"
− sample/xml-test.egi 
@@ -1,49 +0,0 @@-(load "lib/tree/xml.egi")--(define $xml1-  <Node "top"-        {<Node "middle1" {<Leaf "bottom1" "text1">-                          <Leaf "bottom1" "text2">-                          <Leaf "bottom1" "text3">-                          <Node "bottom1" {<Leaf "bottom2" "text21">-                                           <Leaf "bottom2" "text100">-                                           <Leaf "bottom2" "text22">}>-                          }>-         <Node "middle2" {<Leaf "bottom3" "text31">-                          <Leaf "bottom3" "text32">-                          <Leaf "bottom3" "text33">-                          <Leaf "bottom3" "text31">-                          <Leaf "bottom3" "text35">-                          }>--         <Node "middle3" {<Leaf "bottom4" "text41">-                          <Leaf "bottom4"  "text42">-                          <Node "bottom4" {<Leaf "bottom2" "text51">-                                           <Leaf "bottom2" "text100">-                                           <Leaf "bottom2" "text53">}>-                          <Leaf "bottom4"  "text44">-                          <Leaf "bottom4"  "text53">-                          }>-         }>)---;; List up all tags.-(test (match-all xml1 xml-        [<descendant <mnode $tag _>  _> [tag]]))-; {top middle1 middle2 middle3 bottom1 bottom4}--;; List up all nodes which has more than two same child nodes.-(test (match-all xml1 xml-        [<descendant <mnode $tag <cons $x <cons ,x _>>>>-         [tag x]]))-; {[middle2 <Leaf bottom3 text31>] [middle2 <Leaf bottom3 text31>]}--;; List up all nodes which has more than two same descendant nodes.-(test (match-all xml1 xml-        [<descendant-          <mnode $tag-           <cons <descendant $x>-            <cons <descendant ,x>-             _>>>>-         [tag x]]))-; {[middle2 <Leaf bottom3 text31>] [middle2 <Leaf bottom3 text31>] [top <Leaf bottom2 text100>] [top <Leaf bottom2 text100>]}
test/Test.hs view
@@ -16,71 +16,48 @@ import           Language.Egison import           Language.Egison.Core import           Language.Egison.CmdOptions-import qualified Language.Egison.Parser         as Parser-import qualified Language.Egison.ParserNonS     as ParserNonS+import           Language.Egison.Parser import           Language.Egison.Pretty import           Language.Egison.Primitives import           Language.Egison.Types  main :: IO () main =-  defaultMain . hUnitTestToTests . test $ nonSTests ++ sExprTests-  where-    sExprTests = map runTestCase     testCases-    nonSTests  = map runTestCaseNonS nonSTestCases+  defaultMain . hUnitTestToTests . test $ map runTestCase testCases  testCases :: [FilePath] testCases =   [ "test/syntax.egi"   , "test/primitive.egi"+  , "test/lib/core/base.egi"+  , "test/lib/core/collection.egi"+  , "test/lib/core/maybe.egi"+  , "test/lib/core/number.egi"+  , "test/lib/core/order.egi"+  , "test/lib/core/string.egi"+  , "test/lib/math/algebra.egi"+  , "test/lib/math/analysis.egi"+  , "test/lib/math/arithmetic.egi"   , "test/lib/math/tensor.egi" -  , "sample/poker-hands.egi"-  , "sample/poker-hands-with-joker.egi"   , "sample/mahjong.egi" -- for testing pattern functions   , "sample/primes.egi" -- for testing pattern matching with infinitely many results   , "sample/sat/cdcl.egi" -- for testing a practical program using pattern matching-  , "sample/math/number/17th-root-of-unity.egi" -- for testing rewriting of mathematical expressions+  , "sample/poker-hands.egi"+  , "sample/poker-hands-with-joker.egi"+   , "sample/math/geometry/riemann-curvature-tensor-of-S2.egi" -- for testing tensor index notation   , "sample/math/geometry/riemann-curvature-tensor-of-T2.egi" -- for testing tensor index notation and math quote   , "sample/math/geometry/curvature-form.egi" -- for testing differential form   , "sample/math/geometry/hodge-laplacian-polar.egi" -- for testing "..." in tensor indices-  ]--nonSTestCases :: [FilePath]-nonSTestCases =-  [ "nons-test/test/syntax.egi"-  , "nons-test/test/primitive.egi"-  , "nons-test/test/lib/core/base.egi"-  , "nons-test/test/lib/core/collection.egi"-  , "nons-test/test/lib/core/number.egi"-  , "nons-test/test/lib/core/order.egi"-  , "nons-test/test/lib/core/string.egi"-  , "nons-test/test/lib/math/algebra.egi"-  , "nons-test/test/lib/math/analysis.egi"-  , "nons-test/test/lib/math/arithmetic.egi"--  , "nons-sample/math/geometry/curvature-form.egi"-  , "nons-sample/math/geometry/hodge-laplacian-polar.egi" -- for testing "..." in tensor indices+  , "sample/math/number/17th-root-of-unity.egi" -- for testing rewriting of mathematical expressions   ]  runTestCase :: FilePath -> Test runTestCase file = TestLabel file . TestCase $ do   env <- initialEnv defaultOption   assertEgisonM $ do-    exprs <- Parser.loadFile file-    let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs-    env' <- recursiveBind env bindings-    forM_ tests $ evalExprDeep env'-  where-    assertEgisonM :: EgisonM a -> Assertion-    assertEgisonM m = fromEgisonM m >>= assertString . either show (const "")--runTestCaseNonS :: FilePath -> Test-runTestCaseNonS file = TestLabel file . TestCase $ do-  env <- initialEnv (defaultOption { optSExpr = False })-  assertEgisonM $ do-    exprs <- ParserNonS.loadFile file+    exprs <- loadFile file     let (bindings, tests) = foldr collectDefsAndTests ([], []) exprs     env' <- recursiveBind env bindings     forM_ tests $ evalExprDeep env'
+ test/dp.egi view
@@ -0,0 +1,47 @@+literal := integer++deleteLiteral l cnf :=+  map (\matchAll as multiset integer with+       | (!#l & $x) :: _ -> x)+      cnf++deleteClausesWith l cnf :=+  matchAll cnf as multiset (multiset integer) with+  | (!(#l :: _) & $c) :: _ -> c++assignTrue l cnf :=+  deleteLiteral (neg l) (deleteClausesWith l cnf)++resolveOn v cnf :=+  matchAll cnf as multiset (multiset integer) with+  | {(#v :: (@ & $xs)) :: (#(neg v) :: (@ & $ys)) :: _,+     !($l :: _, #(neg l) :: _)}+    -> unique (xs ++ ys)++dp vars cnf :=+  match (vars, cnf) as (multiset literal, multiset (multiset literal)) with+  -- satisfiable+  | (_, []) -> True+  -- unsatisfiable+  | (_, [] :: _) -> False+  -- 1-literal rule+  | (_, (($l :: []) :: _))+  -> dp (delete (abs l) vars) (assignTrue l cnf)+  -- pure literal rule (positive)+  | ($v :: $vs, !((#(neg v) :: _) :: _))+  -> dp vs (assignTrue v cnf)+  -- pure literal rule (negative)+  | ($v :: $vs, !((#v :: _) :: _))+  -> dp vs (assignTrue (neg v) cnf)+  -- otherwise+  | ($v :: $vs, _)+  -> dp vs (resolveOn v cnf +++            deleteClausesWith v (deleteClausesWith (neg v) cnf))++assertEqual "dp" (dp [1] [[1]]) True+assertEqual "dp" (dp [1] [[1],[-1]]) False+assertEqual "dp" (dp [1,2,3] [[1,2],[-1,3],[1,-3]]) True+assertEqual "dp" (dp [1,2] [[1,2],[-1,-2],[1,-2]]) True+assertEqual "dp" (dp [1,2] [[1,2],[-1,-2],[1,-2],[-1,2]]) False+assertEqual "dp" (dp [1,2,3,4,5] [[-1,-2,3],[-1,-2,-3],[1,2,3,4],[-4,-2,3],[5,1,2,-3],[-3,1,-5],[1,-2,3,4],[1,-2,-3,5]]) True+assertEqual "dp" (dp [1,2] [[-1,-2],[1]]) True
test/lib/core/base.egi view
@@ -1,68 +1,60 @@-;;-;; Matchers-;;-(assert "bool's value pattern"-  (match [#t #f] [bool bool]-    {[[,#t ,#f] #t]-     [_ #f]}))+--+-- Matchers+-- -(assert "char's value pattern"-  (match c#a char-    {[,c#a #t]-     [_ #f]}))+assert "bool's value pattern"+  (match (True, False) as (bool, bool) with+   | #(True, False) -> True+   | _ -> False) -(assert "integer's value pattern"-  (match 10 integer-    {[,10 #t]-     [_ #f]}))+assert "char's value pattern"+  (match 'a' as char with+   | #'a' -> True+   | _ -> False) -(assert "float's value pattern"-  (match 0.1 float-    {[,0.1 #t]-     [_ #f]}))+assert "integer's value pattern"+  (match 10 as integer with+   | #10 -> True+   | _ -> False) -;;-;; Utility-;;-(assert-equal "id"-  (id 1)-  1)+assert "float's value pattern"+  (match 0.1 as float with+   | #0.1 -> True+   | _ -> False) -(assert-equal "fst"-  (fst [1 2])-  1)+--+-- Utility+--+assertEqual "id" (id 1) 1 -(assert-equal "snd"-  (snd [1 2])-  2)+assertEqual "fst" (fst (1, 2)) 1 -(assert-equal "compose - case 1"-  ((compose fst snd) [[1 2] 3])-  2)+assertEqual "snd" (snd (1, 2)) 2 -(assert-equal "compose - case 2"-  ((compose fst snd fst) [[1 [2 3]] 4])-  2)+assertEqual "compose" ((compose fst snd) ((1, 2), 3)) 2 -; (assert-equal "ref"-;  (ref (| 1 2 3 |) 2)-;  2)+assertEqual "eqAs" (eqAs integer 1 1) True -(assert-equal "eq?/m"-  (eq?/m integer 1 1)-  #t)+--+-- Booleans+--+assertEqual "and"+  [True && True, True && False, False && True, False && False]+  [True, False, False, False] -;;-;; Booleans-;;-(assert-equal "and"-  [(and #t #t) (and #t #f) (and #f #t) (and #f #f)]-  [#t #f #f #f])+assertEqual "or"+  [True || True, True || False, False || True, False || False]+  [True, True, True, False] -(assert-equal "or"-  [(or #t #t) (or #t #f) (or #f #t) (or #f #f)]-  [#t #t #t #f])+assertEqual "not"+  [not True, not False]+  [False, True] -(assert-equal "not"-  [(not #t) (not #f)]-  [#f #t])+--+-- Unordered-Pair+--++assertEqual "unorderedPair matcher"+  (match (1, 2) as unorderedPair integer with+   | (#2, $x) -> x)+  1
test/lib/core/collection.egi view
@@ -1,427 +1,332 @@-;;;;;-;;;;; Collection Test-;;;;;--;;;-;;; List Pattern-Matching-;;;-(assert "list's value pattern"-  (match {1 2 3} (list integer)-    {[,{@{@{1}} @{2 @{3}}} #t]-     [_ #f]}))--(assert "list's nil - case 1"-  (match {} (list integer)-    {[<nil> #t]-     [_ #f]}))--(assert "list's nil - case 2"-  (match {1} (list integer)-    {[<nil> #f]-     [_ #t]}))--(assert-equal "list's cons"-  (match {1 2 3} (list integer)-    {[<cons $n $ns> [n ns]]})-  [1 {2 3}])+--+-- This file has been auto-generated by egison-translator.+-- -(assert-equal "list's cons with value pattern"-  (match {1 2 3} (list integer)-    {[<cons ,1 $ns> ns]})-  {2 3})+assert+  "list's value pattern"+  (match [1, 2, 3] as list integer with+    | #([1] ++ 2 :: [3]) -> True+    | _ -> False) -(assert-equal "list's snoc"-  (match {1 2 3} (list integer)-    {[<snoc $n $ns> [n ns]]})-  [3 {1 2}])+assert+  "list's nil - case 1"+  (match [] as list integer with+    | [] -> True+    | _ -> False) -(assert-equal "list's snoc with value pattern"-  (match {1 2 3} (list integer)-    {[<snoc ,3 $ns> ns]})-  {1 2})+assert+  "list's nil - case 2"+  (match [1] as list integer with+    | [] -> False+    | _ -> True) -(assert-equal "list's join"-  (match-all {1 2 3} (list integer)-    [<join $xs $ys> [xs ys]])-  {[{} {1 2 3}]-   [{1} {2 3}]-   [{1 2} {3}]-   [{1 2 3} {}]})+assertEqual+  "list's cons"+  (match [1, 2, 3] as list integer with+    | $n :: $ns -> (n, ns))+  (1, [2, 3]) -(assert-equal "list's join with value pattern"-  (match {1 2 3} (list integer)-    {[<join ,{1} $ns> ns]})-  {2 3})+assertEqual+  "list's cons with value pattern"+  (match [1, 2, 3] as list integer with+    | #1 :: $ns -> ns)+  [2, 3] -(assert-equal "list's nioj"-  (match-all {1 2 3} (list integer)-    [<nioj $xs $ys> [xs ys]])-  {[{} {1 2 3}]-   [{3} {1 2}]-   [{2 3} {1}]-   [{1 2 3} {}]})+assertEqual+  "list's snoc"+  (match [1, 2, 3] as list integer with+    | snoc $n $ns -> (n, ns))+  (3, [1, 2]) -(assert-equal "list's nioj with value pattern"-  (match {1 2 3} (list integer)-    {[<nioj ,{3} $ns> ns]})-  {1 2})+assertEqual+  "list's snoc with value pattern"+  (match [1, 2, 3] as list integer with+    | snoc #3 $ns -> ns)+  [1, 2] -(assert-equal "sorted-list - join-cons 1"-  (match-all {3 1 2 4} (sorted-list integer)-    {[<join _ <cons ,3 $xs>> xs]})-  {{1 2 4}})+assertEqual+  "list's join"+  (matchAll [1, 2, 3] as list integer with+    | $xs ++ $ys -> (xs, ys))+  [([], [1, 2, 3]), ([1], [2, 3]), ([1, 2], [3]), ([1, 2, 3], [])] -(assert-equal "sorted-list - join-cons 2"-  (match-all {3 1 2 4} (sorted-list integer)-    {[<join _ <cons ,2 $xs>> xs]})-  {})+assertEqual+  "list's join with value pattern"+  (match [1, 2, 3] as list integer with+    | #[1] ++ $ns -> ns)+  [2, 3] -;;;-;;; Multiset Pattern-Matching-;;;-(assert "multiset's nil - case 1"-  (match {} (multiset integer)-    {[<nil> #t]-     [_ #f]}))+assertEqual+  "list's nioj"+  (matchAll [1, 2, 3] as list integer with+    | nioj $xs $ys -> (xs, ys))+  [([], [1, 2, 3]), ([3], [1, 2]), ([2, 3], [1]), ([1, 2, 3], [])] -(assert "multiset's nil - case 2"-  (match {1} (multiset integer)-    {[<nil> #f]-     [_ #t]}))+assertEqual+  "list's nioj with value pattern"+  (match [1, 2, 3] as list integer with+    | nioj #[3] $ns -> ns)+  [1, 2] -(assert "multiset's value pattern"-  (match {1 1 1 2 3} (multiset integer)-    {[,{@{@{1}} @{2 @{1 3}} 1} #t]-     [_ #f]}))+assertEqual+  "sorted-list - join-cons 1"+  (matchAll [3, 1, 2, 4] as sortedList integer with+    | _ ++ #3 :: $xs -> xs)+  [[1, 2, 4]] -(assert-equal "multiset's cons"-  (match-all {1 2 3} (multiset integer)-    [<cons $n $ns> [n ns]])-  {[1 {2 3}] [2 {1 3}] [3 {1 2}]})+assertEqual+  "sorted-list - join-cons 2"+  (matchAll [3, 1, 2, 4] as sortedList integer with+    | _ ++ #2 :: $xs -> xs)+  [] -(assert-equal "multiset's cons with value pattern"-  (match {1 2 3} (multiset integer)-    {[<cons ,2 $ns> ns]})-  {1 3})+assert+  "multiset's nil - case 1"+  (match [] as multiset integer with+    | [] -> True+    | _ -> False) -(assert-equal "multiset's join"-  (match-all {1 2 3} (multiset integer)-    [<join $xs $ys> [xs ys]])-  {[{} {1 2 3}] [{1} {2 3}] [{2} {1 3}] [{3} {1 2}] [{1 2} {3}] [{1 3} {2}] [{2 3} {1}] [{1 2 3} {}]})+assert+  "multiset's nil - case 2"+  (match [1] as multiset integer with+    | [] -> False+    | _ -> True) -(assert-equal "multiset's join with value pattern - case 1"-  (match {1 2 3} (multiset integer)-    {[<join ,{1} $ns> ns]})-  {2 3})+assert+  "multiset's value pattern"+  (match [1, 1, 1, 2, 3] as multiset integer with+    | #([1] ++ (2 :: [1, 3]) ++ [1]) -> True+    | _ -> False) -(assert-equal "multiset's join with value pattern - case 2"-  (match-all {1 2 3} (multiset integer)-    [<join ,{1 3} $ys> ys])-  {{2}})+assertEqual+  "multiset's cons"+  (matchAll [1, 2, 3] as multiset integer with+    | $n :: $ns -> (n, ns))+  [(1, [2, 3]), (2, [1, 3]), (3, [1, 2])] -(assert-equal "multiset's join with value pattern - case 3"-  (match-all {1 2 3} (multiset integer)-    [<join ,{1 5 3} $ys> ys])-  {})+assertEqual+  "multiset's cons with value pattern"+  (match [1, 2, 3] as multiset integer with+    | #2 :: $ns -> ns)+  [1, 3] -;;;-;;; Set Pattern-Matching-;;;;-(assert "set's nil - case 1"-  (match {} (set integer)-    {[<nil> #t]-     [_ #f]}))+assertEqual+  "multiset's join"+  (matchAll [1, 2, 3] as multiset integer with+    | $xs ++ $ys -> (xs, ys))+  [ ([], [1, 2, 3])+  , ([1], [2, 3])+  , ([2], [1, 3])+  , ([3], [1, 2])+  , ([1, 2], [3])+  , ([1, 3], [2])+  , ([2, 3], [1])+  , ([1, 2, 3], []) ] -(assert "set's nil - case 2"-  (match {1} (set integer)-    {[<nil> #f]-     [_ #t]}))+assertEqual+  "multiset's join with value pattern - case 1"+  (match [1, 2, 3] as multiset integer with+    | #[1] ++ $ns -> ns)+  [2, 3] -(assert-equal "set's cons"-  (match-all {1 2 3} (set integer)-    [<cons $n $ns> [n ns]])-  {[1 {1 2 3}] [2 {1 2 3}] [3 {1 2 3}]})+assertEqual+  "multiset's join with value pattern - case 2"+  (matchAll [1, 2, 3] as multiset integer with+    | #[1, 3] ++ $ys -> ys)+  [[2]] -(assert-equal "set's cons with value pattern"-  (match {1 2 3} (set integer)-    {[<cons ,2 $ns> ns]})-  {1 2 3})+assertEqual+  "multiset's join with value pattern - case 3"+  (matchAll [1, 2, 3] as multiset integer with+    | #[1, 5, 3] ++ $ys -> ys)+  [] -(assert-equal "set's join"-  (match-all {1 2 3} (set integer)-    [<join $xs $ys> [xs ys]])-  {[{} {1 2 3}] [{1} {1 2 3}] [{2} {1 2 3}] [{3} {1 2 3}] [{1 2} {1 2 3}] [{1 3} {1 2 3}] [{2 3} {1 2 3}] [{1 2 3} {1 2 3}]})+assert+  "set's nil - case 1"+  (match [] as set integer with+    | [] -> True+    | _ -> False) -(assert-equal "set's join with value pattern 1"-  (match-all {1 2 3} (set integer)-    [<join ,{1 3} $ys> ys])-  {{1 2 3}})+assert+  "set's nil - case 2"+  (match [1] as set integer with+    | [] -> False+    | _ -> True) -(assert-equal "set's join with value pattern 2"-  (match-all {1 2 3} (set integer)-    [<join ,{1 5 3} $ys> ys])-  {})+assertEqual+  "set's cons"+  (matchAll [1, 2, 3] as set integer with+    | $n :: $ns -> (n, ns))+  [(1, [1, 2, 3]), (2, [1, 2, 3]), (3, [1, 2, 3])] -;;-;; Simple accessors-;;-(assert-equal "nth"-  (nth 1 {1 2 3})-  1)+assertEqual+  "set's cons with value pattern"+  (match [1, 2, 3] as set integer with+    | #2 :: $ns -> ns)+  [1, 2, 3] -(assert-equal "take"-  (take 2 {1 2 3})-  {1 2})+assertEqual+  "set's join"+  (matchAll [1, 2, 3] as set integer with+    | $xs ++ $ys -> (xs, ys))+  [ ([], [1, 2, 3])+  , ([1], [1, 2, 3])+  , ([2], [1, 2, 3])+  , ([3], [1, 2, 3])+  , ([1, 2], [1, 2, 3])+  , ([1, 3], [1, 2, 3])+  , ([2, 3], [1, 2, 3])+  , ([1, 2, 3], [1, 2, 3]) ] -(assert-equal "drop"-  (drop 2 {1 2 3})-  {3})+assertEqual+  "set's join with value pattern 1"+  (matchAll [1, 2, 3] as set integer with+    | #[1, 3] ++ $ys -> ys)+  [[1, 2, 3]] -(assert-equal "take-and-drop"-  (take-and-drop 2 {1 2 3})-  [{1 2} {3}])+assertEqual+  "set's join with value pattern 2"+  (matchAll [1, 2, 3] as set integer with+    | #[1, 5, 3] ++ $ys -> ys)+  [] -(assert-equal "take-while"-  (take-while (lt? $ 10) primes)-  {2 3 5 7})+assertEqual "nth" (nth 1 [1, 2, 3]) 1 -;;-;; cons, car, cdr-;;+assertEqual "take" (take 2 [1, 2, 3]) [1, 2] -(assert-equal "cons"-  (cons 1 {2 3})-  {1 2 3})+assertEqual "drop" (drop 2 [1, 2, 3]) [3] -(assert-equal "car"-  (car {1 2 3})-  1)+assertEqual "take-and-drop" (takeAndDrop 2 [1, 2, 3]) ([1, 2], [3]) -(assert-equal "cdr"-  (cdr {1 2 3})-  {2 3})+assertEqual "take-while" (takeWhile 1#(%1 < 10) primes) [2, 3, 5, 7] -(assert-equal "rac"-  (rac {1 2 3})-  3)+assertEqual "head" (head [1, 2, 3]) 1+assertEqual "tail" (tail [1, 2, 3]) [2, 3]+assertEqual "last" (last [1, 2, 3]) 3+assertEqual "init" (init [1, 2, 3]) [1, 2] -(assert-equal "rdc"-  (rdc {1 2 3})-  {1 2})+assertEqual "uncons" (uncons [1, 2, 3]) (1, [2, 3])+assertEqual "unsnoc" (unsnoc [1, 2, 3]) ([1, 2], 3) -;;-;; List Functions-;;-(assert-equal "length"-  (length {1 2 3})-  3)+assertEqual "isEmpty" (isEmpty [])  True+assertEqual "isEmpty" (isEmpty [1]) False -(assert-equal "map"-  (map (* $ 2) {1 2 3})-  {2 4 6})+assertEqual "length" (length [1, 2, 3]) 3 -(assert-equal "map2"-  (map2 (* $ $) {1 2 3} {10 20 30})-  {10 40 90}-  )+assertEqual "map" (map 1#(%1 * 2) [1, 2, 3]) [2, 4, 6] -(assert-equal "filter"-  (let {[$odd? (lambda [$n] (eq? (modulo n 2) 1))]}-    (filter odd? {1 2 3}))-  {1 3})+assertEqual "map2" (map2 (*) [1, 2, 3] [10, 20, 30]) [10, 40, 90] -(assert-equal "zip"-  (zip {1 2 3} {10 20 30})-  {[1 10] [2 20] [3 30]})+assertEqual+  "filter"+  (let isOdd n := modulo n 2 = 1+    in filter isOdd [1, 2, 3])+  [1, 3] -(assert-equal "lookup"-  (lookup 2 {[1 10] [2 20] [3 30]})-  20)+assertEqual "zip" (zip [1, 2, 3] [10, 20, 30]) [(1, 10), (2, 20), (3, 30)] -(assert-equal "foldr"-  (foldr (lambda [$n $ns] {n @ns}) {} {1 2 3})-  {1 2 3})+assertEqual "lookup" (lookup 2 [(1, 10), (2, 20), (3, 30)]) 20 -(assert-equal "foldl"-  (foldl (lambda [$ns $n] {n @ns}) {} {1 2 3})-  {3 2 1})+assertEqual "foldr" (foldr (\n ns -> n :: ns) [] [1, 2, 3]) [1, 2, 3] -(assert-equal "scanl"-  (scanl (lambda [$r $n] (* r n)) 2 {2 2 2})-  {2 4 8 16})+assertEqual "foldl" (foldl (\ns n -> n :: ns) [] [1, 2, 3]) [3, 2, 1] -(assert-equal "append"-  (append {1 2} {3 4 5})-  {1 2 3 4 5})+assertEqual "scanl" (scanl (\r n -> r * n) 2 [2, 2, 2]) [2, 4, 8, 16] -(assert-equal "concat"-  (concat {{1 2} {3 4 5}})-  {1 2 3 4 5})+assertEqual "append" ([1, 2] ++ [3, 4, 5]) [1, 2, 3, 4, 5] -(assert-equal "reverse"-  (reverse {1 2 3})-  {3 2 1})+assertEqual "concat" (concat [[1, 2], [3, 4, 5]]) [1, 2, 3, 4, 5] -(assert-equal "intersperse"-  (intersperse {0} {{1 2} {3 3} {4} {}})-  {{1 2} {0} {3 3} {0} {4} {0} {}})+assertEqual "reverse" (reverse [1, 2, 3]) [3, 2, 1] -(assert-equal "intercalate"-  (intercalate {0} {{1 2} {3 3} {4} {}})-  {1 2 0 3 3 0 4 0})+assertEqual+  "intersperse"+  (intersperse [0] [[1, 2], [3, 3], [4], []])+  [[1, 2], [0], [3, 3], [0], [4], [0], []] -(assert-equal "split"-  (split {0} {1 2 0 3 3 0 4 0})-  {{1 2} {3 3} {4} {}})+assertEqual+  "intercalate"+  (intercalate [0] [[1, 2], [3, 3], [4], []])+  [1, 2, 0, 3, 3, 0, 4, 0] -(assert-equal "split/m"-  (split/m integer {0} {1 2 0 3 3 0 4 0})-  {{1 2} {3 3} {4} {}})+assertEqual+  "split"+  (split [0] [1, 2, 0, 3, 3, 0, 4, 0])+  [[1, 2], [3, 3], [4], []] -(assert-equal "find-cycle"-  (find-cycle {1 3 4 5 2 7 5 2 7 5 2 7})-  [{1 3 4} {5 2 7}])+assertEqual+  "splitAs"+  (splitAs integer [0] [1, 2, 0, 3, 3, 0, 4, 0])+  [[1, 2], [3, 3], [4], []] -(assert-equal "repeat"-  (take 5 (repeat {1 2 3}))-  {1 2 3 1 2})+assertEqual+  "find-cycle"+  (findCycle [1, 3, 4, 5, 2, 7, 5, 2, 7, 5, 2, 7])+  ([1, 3, 4], [5, 2, 7]) -(assert-equal "repeat1"-  (take 5 (repeat1 2))-  {2 2 2 2 2})+assertEqual "repeat" (take 5 (repeat [1, 2, 3])) [1, 2, 3, 1, 2] -;;-;; Others-;;-(assert-equal "all - case 1"-  (all (eq? $ 1) {1 1 1})-  #t)+assertEqual "repeat1" (take 5 (repeat1 2)) [2, 2, 2, 2, 2] -(assert-equal "all - case 2"-  (all (eq? $ 1) {1 1 2})-  #f)+assertEqual "all - case 1" (all 1#(%1 = 1) [1, 1, 1]) True -(assert-equal "any - case 1"-  (any (eq? $ 1) {0 1 0})-  #t)+assertEqual "all - case 2" (all 1#(%1 = 1) [1, 1, 2]) False -(assert-equal "any - case 2"-  (any (eq? $ 1) {0 0 0})-  #f)+assertEqual "any - case 1" (any 1#(%1 = 1) [0, 1, 0]) True -(assert-equal "from"-  (take 3 (from 2))-  {2 3 4})+assertEqual "any - case 2" (any 1#(%1 = 1) [0, 0, 0]) False -(assert-equal "between"-  (between 2 5)-  {2 3 4 5})+assertEqual "from" (take 3 (from 2)) [2, 3, 4] -;;-;; Multiset Functions-;;-(assert-equal "add - case 1"-  (add 1 {2 3})-  {2 3 1})+assertEqual "between" (between 2 5) [2, 3, 4, 5] -(assert-equal "add - case 2"-  (add 1 {1 2 3})-  {1 2 3})+assertEqual "add - case 1" (add 1 [2, 3]) [2, 3, 1] -(assert-equal "add/m - case 1"-  (add/m integer 1 {2 3})-  {2 3 1})+assertEqual "add - case 2" (add 1 [1, 2, 3]) [1, 2, 3] -(assert-equal "add/m - case 2"-  (add/m integer 1 {1 2 3})-  {1 2 3})+assertEqual "addAs - case 1" (addAs integer 1 [2, 3]) [2, 3, 1] -(assert-equal "delete-first"-  (delete-first 2 {1 2 3 2})-  {1 3 2})+assertEqual "addAs - case 2" (addAs integer 1 [1, 2, 3]) [1, 2, 3] -(assert-equal "delete-first/m"-  (delete-first/m integer 2 {1 2 3 2})-  {1 3 2})+assertEqual "delete-first" (deleteFirst 2 [1, 2, 3, 2]) [1, 3, 2] -(assert-equal "delete"-  (delete 2 {1 2 3 1 2 3})-  {1 3 1 3})+assertEqual "delete-firstAs" (deleteFirstAs integer 2 [1, 2, 3, 2]) [1, 3, 2] -(assert-equal "delete/m"-  (delete/m integer 2 {1 2 3 1 2 3})-  {1 3 1 3})+assertEqual "delete" (delete 2 [1, 2, 3, 1, 2, 3]) [1, 3, 1, 3] -(assert-equal "difference"-  (difference {1 2 3} {1 3})-  {2})+assertEqual "deleteAs" (deleteAs integer 2 [1, 2, 3, 1, 2, 3]) [1, 3, 1, 3] -(assert-equal "difference/m"-  (difference/m integer {1 2 3} {1 3})-  {2})+assertEqual "difference" (difference [1, 2, 3] [1, 3]) [2] -(assert-equal "union"-  (union {1 2 3} {1 3 4})-  {1 2 3 4})+assertEqual "differenceAs" (differenceAs integer [1, 2, 3] [1, 3]) [2] -(assert-equal "union/m"-  (union/m integer {1 2 3} {1 3 4})-  {1 2 3 4})+assertEqual "union" (union [1, 2, 3] [1, 3, 4]) [1, 2, 3, 4] -(assert-equal "intersect"-  (intersect {1 2 3} {1 3 4})-  {1 3})+assertEqual "unionAs" (unionAs integer [1, 2, 3] [1, 3, 4]) [1, 2, 3, 4] -(assert-equal "intersect/m"-  (intersect/m integer {1 2 3} {1 3 4})-  {1 3})+assertEqual "intersect" (intersect [1, 2, 3] [1, 3, 4]) [1, 3] -;;-;; Simple predicate-;;+assertEqual "intersectAs" (intersectAs integer [1, 2, 3] [1, 3, 4]) [1, 3] -(assert-equal "member? - case 1"-  (member? 1 {1 3 1 4})-  #t)+assertEqual "member - case 1" (member 1 [1, 3, 1, 4]) True -(assert-equal "member? - case 2"-  (member? 2 {1 3 1 4})-  #f)+assertEqual "member - case 2" (member 2 [1, 3, 1, 4]) False -(assert-equal "member?/m - case 1"-  (member?/m integer 1 {1 3 1 4})-  #t)+assertEqual "memberAs - case 1" (memberAs integer 1 [1, 3, 1, 4]) True -(assert-equal "member?/m - case 2"-  (member?/m integer 2 {1 3 1 4})-  #f)+assertEqual "memberAs - case 2" (memberAs integer 2 [1, 3, 1, 4]) False -;;-;; Counting-;;-(assert-equal "count"-  (count 1 {1 3 1 4})-  2)+assertEqual "count" (count 1 [1, 3, 1, 4]) 2 -(assert-equal "count/m"-  (count/m integer 1 {1 3 1 4})-  2)+assertEqual "countAs" (countAs integer 1 [1, 3, 1, 4]) 2 -(assert-equal "frequency"-  (frequency {1 3 1 4})-  {[1 2] [3 1] [4 1]})+assertEqual "frequency" (frequency [1, 3, 1, 4]) [(1, 2), (3, 1), (4, 1)] -(assert-equal "frequency/m"-  (frequency/m integer {1 3 1 4})-  {[1 2] [3 1] [4 1]})+assertEqual+  "frequencyAs"+  (frequencyAs integer [1, 3, 1, 4])+  [(1, 2), (3, 1), (4, 1)] -;;-;; Set Functions-;;-(assert-equal "unique"-  (unique {1 2 3 2 1 4})-  {1 2 3 4})+assertEqual "unique" (unique [1, 2, 3, 2, 1, 4]) [1, 2, 3, 4] -(assert-equal "unique/m"-  (unique/m integer {1 2 3 2 1 4})-  {1 2 3 4})+assertEqual "uniqueAs" (uniqueAs integer [1, 2, 3, 2, 1, 4]) [1, 2, 3, 4]
+ test/lib/core/maybe.egi view
@@ -0,0 +1,22 @@+--+-- Maybe+--++assertEqual "nothing pattern and Just"+  (matchAll Just 1 as maybe integer with+    | nothing -> "error")+  []++assertEqual "just pattern and Just"+  (matchAll Just 1 as maybe integer with+    | just $x -> x)+  [1]++assert "nothing pattern and Nothing"+  (match Nothing as maybe integer with+    | nothing -> True)++assertEqual "just pattern and Nothing"+  (matchAll Nothing as maybe integer with+    | just $x -> "error")+  []
test/lib/core/number.egi view
@@ -1,143 +1,118 @@-;;-;; Matcher-;;-(assert-equal "nat's o - case 1"-  (match 0 nat-    {[<o> #t]-     [_ #f]})-  #t)+--+-- Matcher+-- -(assert-equal "nat's o - case 2"-  (match 1 nat-    {[<o> #t]-     [_ #f]})-  #f)+assertEqual "nat's o - case 1"+  (match 0 as nat with+    | o -> True+    | _ -> False)+  True -(assert-equal "nat's s - case 1"-  (match 10 nat-    {[<s $n> n]})-  9)+assertEqual "nat's o - case 2"+  (match 1 as nat with+    | o -> True+    | _ -> False)+  False -(assert-equal "nat's s - case 2"-  (match 0 nat-    {[<s <o>> #t]-     [_ #f]})-  #f)+assertEqual "nat's s - case 1"+  (match 10 as nat with+    | s $n -> n)+  9 -;;-;; Sequences-;;-(assert-equal "nats"-  (take 10 nats)-  {1 2 3 4 5 6 7 8 9 10})+assertEqual "nat's s - case 2"+  (match 0 as nat with+    | s o -> True+    | _ -> False)+  False -(assert-equal "nats0"-  (take 10 nats0)-  {0 1 2 3 4 5 6 7 8 9})+--+-- Sequences+-- -(assert-equal "odds"-  (take 10 odds)-  {1 3 5 7 9 11 13 15 17 19})+assertEqual "nats" (take 10 nats) [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] -(assert-equal "evens"-  (take 10 evens)-  {2 4 6 8 10 12 14 16 18 20})+assertEqual "nats0" (take 10 nats0) [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] -(assert-equal "primes"-  (take 10 primes)-  {2 3 5 7 11 13 17 19 23 29})+assertEqual "odds" (take 10 odds) [1, 3, 5, 7, 9, 11, 13, 15, 17, 19] -;;-;; Natural numbers-;;-(assert-equal "divisor?"-  (divisor? 10 5)-  #t)+assertEqual "evens" (take 10 evens) [2, 4, 6, 8, 10, 12, 14, 16, 18, 20] -(assert-equal "find-factor"-  (find-factor 100)-  2)+assertEqual "primes" (take 10 primes) [2, 3, 5, 7, 11, 13, 17, 19, 23, 29] -(assert-equal "p-f"-  (p-f 100)-  {2 2 5 5})+--+-- Natural numbers+-- -(assert-equal "odd? - case 1"-  (odd? 3)-  #t)+assertEqual "divisor" (divisor 10 5) True -(assert-equal "odd? - case 2"-  (odd? 4)-  #f)+assertEqual "find-factor" (findFactor 100) 2 -(assert-equal "even? - case 1"-  (even? 4)-  #t)+assertEqual "p-f" (pF 100) [2, 2, 5, 5] -(assert-equal "even? - case 2"-  (even? 5)-  #f)+assertEqual "isOdd - case 1" (isOdd 3) True -(assert-equal "prime? - case 1"-  (prime? 17)-  #t)+assertEqual "isOdd - case 2" (isOdd 4) False -(assert-equal "prime? - case 2"-  (prime? 18)-  #f)+assertEqual "isEven - case 1" (isEven 4) True -(assert-equal "perm"-  (perm 5 2)-  20)+assertEqual "isEven - case 2" (isEven 5) False -(assert-equal "comb"-  (comb 5 2)-  10)+assertEqual "isPrime - case 1" (isPrime 17) True -(assert-equal "n-adic - case 1"-  (n-adic 10 123)-  {1 2 3})+assertEqual "isPrime - case 2" (isPrime 18) False -(assert-equal "n-adic - case 2"-  (n-adic 2 10)-  {1 0 1 0})+assertEqual "perm" (perm 5 2) 20 -;;-;; Dicimal fractions-;;-(assert-equal "rtod"-  (2#[%1 (take 10 %2)] (rtod (/ 6 35)))-  [0 {1 7 1 4 2 8 5 7 1 4}])+assertEqual "comb" (comb 5 2) 10 -(assert-equal "rtod'"-  (rtod' (/ 6 35))-  [0 {1} {7 1 4 2 8 5}])+assertEqual "n-adic - case 1" (nAdic 10 123) [1, 2, 3] -(assert-equal "show-decimal"-  (show-decimal 10 (/ 6 35))-  "0.1714285714")+assertEqual "n-adic - case 2" (nAdic 2 10) [1, 0, 1, 0] -(assert-equal "show-decimal'"-  (show-decimal' (/ 6 35))-  "0.1 714285 ...")+assertEqual "rtod"+  (2#(%1, take 10 %2) (rtod (6 / 35)))+  (0, [1, 7, 1, 4, 2, 8, 5, 7, 1, 4]) -(assert-equal "regular-continued-fraction sqrt of 2"-  (rtof (regular-continued-fraction 1 {2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2}))-  1.4142135623730951)+assertEqual "rtod'" (rtod' (6 / 35)) (0, [1], [7, 1, 4, 2, 8, 5]) -(assert-equal "regular-continued-fraction pi"-  (rtof (regular-continued-fraction 3 {7 15 1 292 1 1 1 2 1 3 1 14 2 1 1 2 2 2 2 1 84 2 1 1 15 3 13}))-  3.141592653589793)+assertEqual "show-decimal" (showDecimal 10 (6 / 35)) "0.1714285714" -(assert-equal "continued-fraction pi"-  (rtof (continued-fraction 3 {7 15 1 292 1 1 1 2 1 3 1 14 2 1 1 2 2 2 2 1 84 2 1 1 15 3 13}-                              {1 1  1 1   1 1 1 1 1 1 1 1  1 1 1 1 1 1 1 1 1  1 1 1 1  1 1}))-  3.141592653589793)+assertEqual "show-decimal'" (showDecimal' (6 / 35)) "0.1 714285 ..." -(assert-equal "regular-continued-fraction-of-sqrt case 1"-  (2#[%1 (take 10 %2)] (regular-continued-fraction-of-sqrt 2))-  [1 {2 2 2 2 2 2 2 2 2 2}])-  -(assert-equal "regular-continued-fraction-of-sqrt case 2"-  (rtof (regular-continued-fraction (2#[%1 (take 100 %2)] (regular-continued-fraction-of-sqrt 2))))-  1.4142135623730951)+assertEqual+  "regular-continued-fraction sqrt of 2"+  (rtof+     (regularContinuedFraction+        1+        [2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2]))+  1.4142135623730951++assertEqual "regular-continued-fraction pi"+  (rtof+     (regularContinuedFraction+        3+        [7, 15, 1, 292, 1, 1, 1, 2, 1, 3, 1, 14, 2, 1, 1, 2, 2, 2, 2, 1, 84, 2,+         1, 1, 15, 3, 13]))+  3.141592653589793++assertEqual "continued-fraction pi"+  (rtof+     (continuedFraction+        3+        [7, 15, 1, 292, 1, 1, 1, 2, 1, 3, 1, 14, 2, 1, 1, 2, 2, 2, 2, 1, 84, 2,+         1, 1, 15, 3, 13]+        [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,+         1, 1, 1]))+  3.141592653589793++assertEqual+  "regular-continued-fraction-of-sqrt case 1"+  (2#(%1, take 10 %2) (regularContinuedFractionOfSqrt 2))+  (1, [2, 2, 2, 2, 2, 2, 2, 2, 2, 2])++assertEqual+  "regular-continued-fraction-of-sqrt case 2"+  (rtof+     (regularContinuedFraction+        (2#(%1, take 100 %2) (regularContinuedFractionOfSqrt 2))))+  1.4142135623730951
test/lib/core/order.egi view
@@ -1,35 +1,35 @@-(assert-equal "compare - case 1"+assertEqual "compare - case 1"   (compare 10 10)-  <Equal>)+  Equal -(assert-equal "compare - case 2"+assertEqual "compare - case 2"   (compare 11 10)-  <Greater>)+  Greater -(assert-equal "compare - case 3"+assertEqual "compare - case 3"   (compare 10 11)-  <Less>)+  Less -(assert-equal "min"-  (min {20 5})-  5)+assertEqual "min"+  (minimum [20, 5])+  5 -(assert-equal "min/fn"-  (min/fn compare {10 20 5 20 30})-  5)+assertEqual "min/fn"+  (min/fn compare [10, 20, 5, 20, 30])+  5 -(assert-equal "max"-  (max {5 30})-  30)+assertEqual "max"+  (maximum [5, 30])+  30 -(assert-equal "max/fn"-  (max/fn compare {10 20 5 20 30})-  30)+assertEqual "max/fn"+  (max/fn compare [10, 20, 5, 20, 30])+  30 -(assert-equal "sort"-  (sort {10 20 5 20 30})-  {5 10 20 20 30})+assertEqual "sort"+  (sort [10, 20, 5, 20, 30])+  [5, 10, 20, 20, 30] -(assert-equal "sort/fn"-  (sort/fn compare {10 20 5 20 30})-  {5 10 20 20 30})+assertEqual "sort/fn"+  (sort/fn compare [10, 20, 5, 20, 30])+  [5, 10, 20, 20, 30]
test/lib/core/string.egi view
@@ -1,99 +1,69 @@-(assert "string's value pattern"-  (match "abc" string-    {[,"abc" #t]-     [_ #f]}))+assert "string's value pattern"+  (match "abc" as string with+    | #"abc" -> True+    | _ -> False) -(assert "string's nil - case 1"-  (match "" string-    {[<nil> #t]-     [_ #f]}))+assert "string's nil - case 1"+  (match "" as string with+    | [] -> True+    | _ -> False) -(assert "string's nil - case 2"-  (match "abc" string-    {[<nil> #f]-     [_ #t]}))+assert "string's nil - case 2"+  (match "abc" as string with+    | [] -> False+    | _ -> True) -(assert-equal "string's cons"-  (match-all "abc" string-    [<cons $x $xs> [x xs]])-  {[c#a "bc"]})+assertEqual "string's cons"+  (matchAll "abc" as string with+    | $x :: $xs -> (x, xs))+  [('a', "bc")] -(assert-equal "string's join"-  (match-all "abc" string-    [<join $xs $ys> [xs ys]])-  {["" "abc"] ["a" "bc"]-   ["ab" "c"] ["abc" ""]})+assertEqual "string's join"+  (matchAll "abc" as string with+    | $xs ++ $ys -> (xs, ys))+  [("", "abc"), ("a", "bc"), ("ab", "c"), ("abc", "")] -;;;-;;; String as collection-;;;-(assert-equal "S.empty? - case 1"-  (S.empty? "")-  #t)+--+-- String as collection+--+assertEqual "S.isEmpty - case 1" (S.isEmpty "") True -(assert-equal "S.empty? - case 2"-  (S.empty? "Egison")-  #f)+assertEqual "S.isEmpty - case 2" (S.isEmpty "Egison") False -(assert-equal "S.car"-  (S.car "Egison")-  c#E)+assertEqual "S.head" (S.head "Egison") 'E' -(assert-equal "S.cdr"-  (S.cdr "Egison")-  "gison")+assertEqual "S.tail" (S.tail "Egison") "gison" -(assert-equal "S.rac"-  (S.rac "Egison")-  c#n)+assertEqual "S.last" (S.last "Egison") 'n' -(assert-equal "S.map"-  (S.map id "Egison")-  "Egison")+assertEqual "S.map" (S.map id "Egison") "Egison" -(assert-equal "S.length"-  (S.length "Egison")-  6)+assertEqual "S.length" (S.length "Egison") 6 -(assert-equal "S.split"+assertEqual "S.split"   (S.split "," "Lisp,Haskell,Egison")-  {"Lisp" "Haskell" "Egison"})+  ["Lisp", "Haskell", "Egison"] -(assert-equal "S.append"-  (S.append "Egi" "son")-  "Egison")+assertEqual "S.append" (S.append "Egi" "son") "Egison" -(assert-equal "S.concat"-  (S.concat {"Egi" "son"})-  "Egison")+assertEqual "S.concat" (S.concat ["Egi", "son"]) "Egison" -(assert-equal "S.intercalate"-  (S.intercalate "," {"Lisp" "Haskell" "Egison"})-  "Lisp,Haskell,Egison")+assertEqual "S.intercalate"+  (S.intercalate "," ["Lisp", "Haskell", "Egison"])+  "Lisp,Haskell,Egison" -;;-;; Characters-;;-(assert-equal "C.between"-  (C.between c#a c#c)-  {c#a c#b c#c})+--+-- Characters+-- -(assert-equal "C.between?"-  (C.between? c#a c#c c#b)-  #t)+assertEqual "C.between" (C.between 'a' 'c') ['a', 'b', 'c'] -(assert-equal "alphabet?"-  (alphabet? c#a)-  #t)+assertEqual "C.isBetween" (C.isBetween 'a' 'c' 'b') True -(assert-equal "alphabets?"-  (alphabets? "Egison")-  #t)+assertEqual "isAlphabet" (isAlphabet 'a') True -(assert-equal "upper-case"-  (upper-case c#e)-  c#E)+assertEqual "isAlphabetString" (isAlphabetString "Egison") True -(assert-equal "lower-case"-  (lower-case c#E)-  c#e)+assertEqual "upper-case" (upperCase 'e') 'E'++assertEqual "lower-case" (lowerCase 'E') 'e'
test/lib/math/algebra.egi view
@@ -1,15 +1,21 @@-(assert-equal "q-f' - case 1"-  (q-f' 1 2 1)-  [-1 -1])+--+-- This file has been auto-generated by egison-translator.+-- -(assert-equal "q-f' - case 2"-  (q-f' 1 1 -1)-  [(/ (+ -1 (sqrt 5)) 2) (/ (+ -1 (* -1 (sqrt 5))) 2)])+assertEqual "q-f' - case 1" (qF' 1 2 1) (-1, -1) -(assert-equal "q-f' - case 3"-  (q-f' 1 (* -1 (/ (+ -1 (sqrt 5)) 2)) 1)-  [(/ (+ -1 (sqrt 5) (sqrt (+ -10 (* -2 (sqrt 5))))) 4) (/ (+ -1 (sqrt 5) (* -1 (sqrt (+ -10 (* -2 (sqrt 5)))))) 4)])+assertEqual+  "q-f' - case 2"+  (qF' 1 1 (-1))+  (((-1) + sqrt 5) / 2, ((-1) + (- sqrt 5)) / 2) -(assert-equal "fifth root of unity"-  (** (/ (+ -1 (sqrt 5) (sqrt (+ -10 (* -2 (sqrt 5))))) 4) 5)-  1)+assertEqual+  "q-f' - case 3"+  (qF' 1 (- (((-1) + sqrt 5) / 2)) 1)+  ( ((-1) + sqrt 5 + sqrt ((-10) + (-2) * sqrt 5)) / 4+  , ((-1) + sqrt 5 + (- sqrt ((-10) + (-2) * sqrt 5))) / 4 )++assertEqual+  "fifth root of unity"+  ((((-1) + sqrt 5 + sqrt ((-10) + (-2) * sqrt 5)) / 4) ^ 5)+  1
test/lib/math/analysis.egi view
@@ -1,42 +1,37 @@-(assert-equal "d/d - case 1"-  (d/d (** x 2) x)-  (* 2 x))--(assert-equal "d/d - case 2"-  (d/d (** a (** x 2)) x)-  (* 2 (** a x^2) (log a) x))+--+-- This file has been auto-generated by egison-translator.+-- -(assert-equal "d/d - case 3"-  (d/d (* (cos x) (sin x)) x)-  (+ (* -1 (sin x)^2) (cos x)^2))+assertEqual "d/d - case 1" (d/d (x ^ 2) x) (2 * x) -(assert-equal "d/d - case 4"-  (d/d (sigmoid z) z)-  (/ (exp (* -1 z)) (+ 1 (* 2 (exp (* -1 z))) (exp (* -1 z))^2)))+assertEqual "d/d - case 2" (d/d (a ^ (x ^ 2)) x) (2 * a ^ (x ^ 2) * log a * x) -(assert-equal "d/d - case 5"-  (d/d (d/d (log x) x) x)-  (/ -1 x^2))+assertEqual "d/d - case 3" (d/d (cos x * sin x) x) ((- (sin x ^ 2)) + cos x ^ 2) -(assert-equal "tailor-expansion - case 1"-  (take 4 (taylor-expansion (** e (* i x)) x 0))-  {(`exp 0) (* (`exp 0) i x) (/ (* -1 (`exp 0) x^2) 2) (/ (* -1 (`exp 0) i x^3) 6)})-;  {1 (* i x) (/ (* -1 x^2) 2) (/ (* -1 i x^3) 6)})+assertEqual+  "d/d - case 4"+  (d/d (sigmoid z) z)+  (exp (- z) / (1 + 2 * exp (- z) + exp (- z) ^ 2)) -;(assert-equal "tailor-expansion - case 2"-;  (take 4 (taylor-expansion (* i (sin x)) x 0))-;  {0 (* i x) 0 (/ (* -1 i x^3) 6)})+assertEqual "d/d - case 5" (d/d (d/d (log x) x) x) ((-1) / x ^ 2) -(assert-equal "multivariate-tailor-expansion - case 1"-  (take 3 (multivariate-taylor-expansion (f x y) [| x y |] [| 0 0 |]))-  {(f 0 0) (+ (* x (f|1 0 0)) (* y (f|2 0 0))) (/ (+ (* x^2 (f|1|1 0 0)) (* x y (f|1|2 0 0)) (* x y (f|2|1 0 0)) (* y^2 (f|2|2 0 0))) 2)})+assertEqual+  "tailor-expansion - case 1"+  (take 4 (taylorExpansion (e ^ (i * x)) x 0))+  [1, i * x, -1 * x ^ 2 / 2, -1 * i * x ^ 3 / 6] -;(assert-equal "multivariate-tailor-expansion - case 2"-;  (take 3 (multivariate-taylor-expansion (** e (+ x y)) [| x y |] [| 0 0 |]))-;  {1 (+ x y) (/ (+ x^2 (* 2 x y) y^2) 2)})+assertEqual+  "multivariate-tailor-expansion - case 1"+  (take 3 (multivariateTaylorExpansion (f x y) [|x, y|] [|0, 0|]))+  [ f 0 0+  , x * f|1 0 0 + y * f|2 0 0+  , (x ^ 2 * f|1|1 0 0 + x * y * f|1|2 0 0 + x * y * f|2|1 0 0 + y ^ 2 * f|2|2+                                                                           0+                                                                           0) / 2 ] -(assert-equal "function expr"-  (let {[$f (function [x y])]}-    (d/d f y))-  (let {[$f (function [x y])]}-    (user-refs f {y})))+assertEqual+  "function expr"+  (let f := function (x, y)+    in d/d f y)+  (let f := function (x, y)+    in userRefs f [y])
test/lib/math/arithmetic.egi view
@@ -1,31 +1,22 @@-(assert-equal "sum"-  (sum (take 5 nats))-  15)+--+-- This file has been auto-generated by egison-translator.+-- -(assert-equal "product"-  (product (take 5 nats))-  120)+assertEqual "sum" (sum (take 5 nats)) 15 -(assert-equal "power"-  (power 2 5)-  32)+assertEqual "product" (product (take 5 nats)) 120 -(assert-equal "** - case 1"-  (power x 3)-  x^3)+assertEqual "power" (power 2 5) 32 -(assert-equal "** - case 2"-  (power (sqrt 2) 4)-  4)+assertEqual "** - case 1" (power x 3) (x ^ 3) -(assert-equal "gcd"-  (gcd 15 40)-  5)+assertEqual "** - case 2" (power (sqrt 2) 4) 4 -(assert-equal "sqrt - case 1"-  (sqrt (/ (* 50 x^2) y))-  (/ (* 5 x (sqrt (* 2 y))) y))+assertEqual "gcd" (gcd 15 40) 5 -(assert-equal "sqrt - case 2"-  (* (sqrt (* 3 x)) (sqrt (* 2 y)))-  (* (sqrt 6) (sqrt x) (sqrt y)))+assertEqual "sqrt - case 1" (sqrt (50 * x ^ 2 / y)) (5 * x * sqrt (2 * y) / y)++assertEqual+  "sqrt - case 2"+  (sqrt (3 * x) * sqrt (2 * y))+  (sqrt 6 * sqrt x * sqrt y)
test/lib/math/tensor.egi view
@@ -1,85 +1,77 @@-(assert-equal "Tensor product - case 1"-  (. [| [| 1 1 |] [| 0 1 |] |]~i~j [| [| 1 1 |] [| 0 1 |] |]_j_k)-  [| [| 1 2 |] [| 0 1 |] |])+--+-- This file has been auto-generated by egison-translator.+-- -(assert-equal "Tensor product - case 2"-  (. [| [| 1 1 |] [| 0 1 |] |]~i~j [| [| 1 1 |] [| 0 1 |] |]_j~k [| [| 1 1 |] [| 0 1 |] |]_k_l)-  [| [| 1 3 |] [| 0 1 |] |]~i_l)+assertEqual+  "Tensor product - case 1"+  ([|[|1, 1|], [|0, 1|]|]~i~j . [|[|1, 1|], [|0, 1|]|]_j_k)+  [|[|1, 2|], [|0, 1|]|] -(assert-equal "Vector *"-  (V.* [| 1 1 0 |] [| 10 5 10 |])-  15)+assertEqual+  "Tensor product - case 2"+  ([|[|1, 1|], [|0, 1|]|]~i~j . [|[|1, 1|], [|0, 1|]|]_j~k . [|[|1, 1|]+  , [|0, 1|]|]_k_l)+  [|[|1, 3|], [|0, 1|]|]~i_l -(assert-equal "Matrix * - case 1"-  (M.* [| [| 1 1 |] [| 0 1 |] |] [| [| 1 1 |] [| 0 1 |] |])-  [| [| 1 2 |] [| 0 1 |] |])+assertEqual "Vector *" (V.* [|1, 1, 0|] [|10, 5, 10|]) 15 -(assert-equal "Matrix * - case 2"-  (M.* [| [| 1 1 |] [| 0 1 |] |] [| [| 1 1 |] [| 0 1 |] |] [| [| 1 1 |] [| 0 1 |] |])-  [| [| 1 3 |] [| 0 1 |] |])+assertEqual+  "Matrix *"+  (M.* [|[|1, 1|], [|0, 1|]|] [|[|1, 1|], [|0, 1|]|])+  [|[|1, 2|], [|0, 1|]|] -(assert-equal "Tensor '+' - case 1"-  (+ 1 [|1 2 3|])-  [|2 3 4|])+assertEqual+  "Matrix determinant"+  (M.det [|[|1, 1|], [|0, 1|]|])+  1 -(assert-equal "Tensor '+' - case 2"-  (+ [|1 2 3|] 1)-  [|2 3 4|])+assertEqual "Tensor '+' - case 1" (1 + [|1, 2, 3|]) [|2, 3, 4|] -(assert-equal "Tensor '+' - case 3"-  (+ [|[|11 12|]-       [|21 22|]-       [|31 32|]|]_i_j-     [|100 200 300|]_i)-  [| [| 111 112 |] [| 221 222 |] [| 331 332 |] |]_i_j)+assertEqual "Tensor '+' - case 2" ([|1, 2, 3|] + 1) [|2, 3, 4|] -(assert-equal "Tensor '+' - case 4"-  (+ [|100 200 300|]_i-     [|[|11 12|]-       [|21 22|]-       [|31 32|]|]_i_j)-  [| [| 111 112 |] [| 221 222 |] [| 331 332 |] |]_i_j)+assertEqual+  "Tensor '+' - case 3"+  ([|[|11, 12|], [|21, 22|], [|31, 32|]|]_i_j + [|100, 200, 300|]_i)+  [|[|111, 112|], [|221, 222|], [|331, 332|]|]_i_j -(assert-equal "Tensor '+' - case 5"-  (+ [|[|1 2 3|]-       [|10 20 30|]|]_i_j-     [|100 200 300|]_j)-  [| [| 101 202 303 |] [| 110 220 330 |] |]_i_j)+assertEqual+  "Tensor '+' - case 4"+  ([|100, 200, 300|]_i + [|[|11, 12|], [|21, 22|], [|31, 32|]|]_i_j)+  [|[|111, 112|], [|221, 222|], [|331, 332|]|]_i_j -(assert-equal "Tensor '+' - case 6"-  (+ [|100 200 300|]_j-     [|[|1 2 3|]-       [|10 20 30|]|]_i_j)-  [| [| 101 110 |] [| 202 220 |] [| 303 330 |] |]_j_i)+assertEqual+  "Tensor '+' - case 5"+  ([|[|1, 2, 3|], [|10, 20, 30|]|]_i_j + [|100, 200, 300|]_j)+  [|[|101, 202, 303|], [|110, 220, 330|]|]_i_j -;(assert-equal "Tensor ∂/∂ - case 1"-;  (∂/∂ [|(f x) (g x)|] x)-;  [|(f|1 x) (g|1 x)|])+assertEqual+  "Tensor '+' - case 6"+  ([|100, 200, 300|]_j + [|[|1, 2, 3|], [|10, 20, 30|]|]_i_j)+  [|[|101, 110|], [|202, 220|], [|303, 330|]|]_j_i -;(assert-equal "Tensor ∂/∂ - case 2"-;  (∂/∂ (f x y z) [|x y z|])-;  [|(f|1 x y z) (f|2 x y z) (f|3 x y z)|])+assertEqual+  "append indices with ..."+  (let A := generateTensor 2#1 [2, 2]+       f %B := B..._j+    in f A_i)+  [|[|1, 1|], [|1, 1|]|]_i_j -;(assert-equal "Tensor ∂/∂ - case 3"-;  (apply [|(∂/∂ $ x) (∂/∂ $ y)|] (f x y))-;  [|(f|1 x y) (f|2 x y)|])+g_i_j := (generateTensor+            (\match as (integer, integer) with+               | ($n, #n) -> function (x, y, z)+               | (_, _) -> 0)+            [3, 3])_i_j -(assert-equal "append indices with ..."-  (let {[$A (generate-tensor 2#1 {2 2})]-        [$f (lambda [%B] B..._j)]}-    (f A_i))-  [| [| 1 1 |] [| 1 1 |] |]_i_j)+assertEqual+  "generate_tensor by using function expr"+  (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 |] |]" -(assert-equal "generate_tensor by using function expr"-  (letrec {[$g__ (generate-tensor-                    (match-lambda [integer integer]-                      {[[$n ,n] (function [x y z])]-                       [[_ _] 0]})-                    {3 3})]}-     (show (with-symbols {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 -(assert-equal "define tensor having value of function expr"-  (letrec {[$g__ [| [| (function [x y z]) 0 0 |] [| 0 (function [x y z]) 0 |] [| 0 0 (function [x y z]) |] |]]}-     (show (with-symbols {i j} (d/d g_i_j x))))-  "[| [| g_1_1|x, 0, 0 |], [| 0, g_2_2|x, 0 |], [| 0, 0, g_3_3|x |] |]")+assertEqual+  "define tensor having value of function expr"+  (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/poker-joker.egi view
@@ -0,0 +1,37 @@+suit := algebraicDataMatcher+  | spade+  | heart+  | club+  | diamond++card := matcher+  | card $ $ as (suit, mod 13) with +    | Card $s $n -> [(s, n)]+    | Joker -> matchAll ([Spade, Heart, Club, Diamond], [1..13])+                     as (set suit, set integer) with+               | ($s :: _, $n :: _) -> (s, n)+  | $ as something with+    | $tgt -> [tgt]++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"+  | card _ $n :: card _ #n :: card _ #n :: card _ #n :: _ :: []+    -> "Four of a kind"+  | card _ $m :: card _ #m :: card _ #m :: card _ $n :: card _ #n :: []+    -> "Full house"+  | card $s _ :: card #s _ :: card #s _ :: card #s _ :: card #s _ :: []+    -> "Flush"+  | card _ $n :: card _ #(n-1) :: card _ #(n-2) :: card _ #(n-3) :: card _ #(n-4) :: []+    -> "Straight"+  | card _ $n :: card _ #n :: card _ #n :: _ :: _ :: []+    -> "Three of a kind"+  | card _ $m :: card _ #m :: card _ $n :: card _ #n :: _ :: []+    -> "Two pair"+  | card _ $n :: card _ #n :: _ :: _ :: _ :: []+    -> "One pair"+  | _ :: _ :: _ :: _ :: _ :: [] -> "Nothing"++assertEqual "poker-joker" (poker [Card Spade 5, Card Spade 6, Joker, Card Spade 8, Card Spade 9]) "Straight flush"+assertEqual "poker-joker" (poker [Card Spade 5, Card Diamond 5, Joker, Card Club 5, Card Heart 7]) "Four of a kind"
+ test/poker.egi view
@@ -0,0 +1,39 @@+suit := algebraicDataMatcher+  | spade+  | heart+  | club+  | diamond++card := algebraicDataMatcher+  | card suit (mod 13)++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"+  | card _ $n :: card _ #n :: card _ #n :: card _ #n :: _ :: []+    -> "Four of a kind"+  | card _ $m :: card _ #m :: card _ #m :: card _ $n :: card _ #n :: []+    -> "Full house"+  | card $s _ :: card #s _ :: card #s _ :: card #s _ :: card #s _ :: []+    -> "Flush"+  | card _ $n :: card _ #(n-1) :: card _ #(n-2) :: card _ #(n-3) :: card _ #(n-4) :: []+    -> "Straight"+  | card _ $n :: card _ #n :: card _ #n :: _ :: _ :: []+    -> "Three of a kind"+  | card _ $m :: card _ #m :: card _ $n :: card _ #n :: _ :: []+    -> "Two pair"+  | card _ $n :: card _ #n :: _ :: _ :: _ :: []+    -> "One pair"+  | _ :: _ :: _ :: _ :: _ :: [] -> "Nothing"+++assertEqual "poker" (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Spade 9])    "Straight flush"+assertEqual "poker" (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 5])   "Four of a kind"+assertEqual "poker" (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 7])   "Full house"+assertEqual "poker" (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 13, Card Spade 9])   "Flush"+assertEqual "poker" (poker [Card Spade 5, Card Club 6, Card Spade 7, Card Spade 8, Card Spade 9])     "Straight"+assertEqual "poker" (poker [Card Spade 5, Card Diamond 5, Card Spade 7, Card Club 5, Card Heart 8])   "Three of a kind"+assertEqual "poker" (poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 10]) "Two pair"+assertEqual "poker" (poker [Card Spade 5, Card Diamond 10, Card Spade 7, Card Club 5, Card Heart 8])  "One pair"+assertEqual "poker" (poker [Card Spade 5, Card Spade 6, Card Spade 7, Card Spade 8, Card Diamond 11]) "Nothing"
test/primitive.egi view
@@ -1,15 +1,163 @@-(assert-equal "less than predicate"-  [(lt? 0.1 1.0) (lt? 1.0 0.1) (lt? 1.0 1.0)]-  [#t #f #f])+assertEqual "numerator" (numerator (13 / 21)) 13 -(assert-equal "less than or equal predicate"-  [(lte? 0.1 1.0) (lte? 1.0 0.1) (lte? 1.0 1.0)]-  [#t #f #t])+assertEqual "denominator" (denominator (13 / 21)) 21 -(assert-equal "greater than predicate"-  [(gt? 0.1 1.0) (gt? 1.0 0.1) (gt? 1.0 1.0)]-  [#f #t #f])+assertEqual "modulo" (modulo (-21) 13) 5 -(assert-equal "greater than or equal predicate"-  [(gte? 0.1 1.0) (gte? 1.0 0.1) (gte? 1.0 1.0)]-  [#f #t #t])+assertEqual "quotient" (quotient (-21) 13) (-1)++assertEqual "remainder" (remainder (-21) 13) (-8)++assertEqual "neg" (neg (-89)) 89++assertEqual "abs" (abs 0)     0+assertEqual "abs" (abs 15)    15+assertEqual "abs" (abs (-89)) 89++assertEqual "lt" (0.1 < 1.0) True+assertEqual "lt" (1.0 < 0.1) False+assertEqual "lt" (1.0 < 1.0) False++assertEqual "lte" (0.1 <= 1.0) True+assertEqual "lte" (1.0 <= 0.1) False+assertEqual "lte" (1.0 <= 1.0) True++assertEqual "gt" (0.1 > 1.0) False+assertEqual "gt" (1.0 > 0.1) True+assertEqual "gt" (1.0 > 1.0) False++assertEqual "gte" (0.1 >= 1.0) False+assertEqual "gte" (1.0 >= 0.1) True+assertEqual "gte" (1.0 >= 1.0) True++assertEqual "round" (round 3.1)    3+assertEqual "round" (round 3.7)    4+assertEqual "round" (round (-2.2)) (-2)+assertEqual "round" (round (-2.7)) (-3)++assertEqual "floor" (floor 3.1)    3+assertEqual "floor" (floor 3.7)    3+assertEqual "floor" (floor (-2.2)) (-3)+assertEqual "floor" (floor (-2.7)) (-3)++assertEqual "ceiling" (ceiling 3.1)    4+assertEqual "ceiling" (ceiling 3.7)    4+assertEqual "ceiling" (ceiling (-2.2)) (-2)+assertEqual "ceiling" (ceiling (-2.7)) (-2)++assertEqual "truncate" (truncate 3.1)    3+assertEqual "truncate" (truncate 3.7)    3+assertEqual "truncate" (truncate (-2.2)) (-2)+assertEqual "truncate" (truncate (-2.7)) (-2)++assertEqual "sqrt" (sqrt 4) 2+assertEqual "sqrt" (sqrt 4.0) 2.0+-- assertEqual "sqrt" (sqrt (-1)) i++-- assertEqual "exp"+--   [exp 1, exp 1.0, exp (-1.0)]+--   [e, 2.718281828459045, 0.36787944117144233]++-- assertEqual "log"+--   [log e, log 10.0]+--   [1, 2.302585092994046]++-- TODO: trigonometric functions+-- * sin+-- * cos+-- * tan+-- * asin+-- * acos+-- * sinh+-- * cosh+-- * tanh+-- * asinh+-- * acosh+-- * atanh++-- tensorSize+-- tensorToList+-- dfOrder++assertEqual "itof" (itof 4)    4.0+assertEqual "itof" (itof (-1)) (-1.0)++assertEqual "rtof" (rtof (3 / 2)) 1.5+assertEqual "rtof" (rtof 1)       1.0++assertEqual "ctoi" (ctoi '1') 49++assertEqual "itoc" (itoc 49) '1'++assertEqual "pack" (pack []) ""+assertEqual "pack" (pack ['E', 'g', 'i', 's', 'o', 'n']) "Egison"++assertEqual "unpack" (unpack "Egison") ['E', 'g', 'i', 's', 'o', 'n']+assertEqual "unpack" (unpack "") []++assertEqual "unconsString" (unconsString "Egison") ('E', "gison")++assertEqual "lengthString" (lengthString "") 0+assertEqual "lengthString" (lengthString "Egison") 6++assertEqual "appendString" (appendString "" "")       ""+assertEqual "appendString" (appendString "" "Egison") "Egison"+assertEqual "appendString" (appendString "Egison" "") "Egison"+assertEqual "appendString" (appendString "Egi" "son") "Egison"++assertEqual "splitString" (splitString "," "") [""]+assertEqual "splitString" (splitString "," "2,3,5,7,11,13") ["2", "3", "5", "7", "11", "13"]++assertEqual "regex" (regex "cde" "abcdefg") [("ab", "cde", "fg")]+assertEqual "regex" (regex "[0-9]+" "abc123defg") [("abc", "123", "defg")]+assertEqual "regex" (regex "a*" "") [("", "", "")]++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+assertEqual "read" (read "[1, 2]")            [1, 2]+assertEqual "read" (read "\"Hello world!\"") "Hello world!"++-- TODO: read-tsv++assertEqual "show" (show 3)              "3"+assertEqual "show" (show 3.14159)        "3.14159"+assertEqual "show" (show [1, 2])         "[1, 2]"+assertEqual "show" (show "Hello world!") "\"Hello world!\""++-- TODO: show-tsv++assertEqual "isBool" (isBool False) True++assertEqual "isInteger" (isInteger 1) True++assertEqual "isRational" (isRational 1)       True+assertEqual "isRational" (isRational (1 / 2)) True+assertEqual "isRational" (isRational 3.1)     False++assertEqual "isScalar" (isScalar 1) True+assertEqual "isScalar" (isScalar [| 1, 2 |]) False++assertEqual "isFloat" (isFloat 1.0) True+assertEqual "isFloat" (isFloat 1)   False++assertEqual "isChar" (isChar 'c') True++assertEqual "isString" (isString "hoge") True++assertEqual "isCollection" (isCollection []) True+assertEqual "isCollection" (isCollection [1]) True++assertEqual "isHash" (isHash {| |}) True+assertEqual "isHash" (isHash {| (1, 2) |}) True++-- TODO: Add a test case where isTensor returns True+assertEqual "isTensor" (isTensor 1)                           False+assertEqual "isTensor" (isTensor [| 1 |])                     True+assertEqual "isTensor" (isTensor (generateTensor (+) [1, 2])) True
test/syntax.egi view
@@ -1,446 +1,659 @@-;;;;;-;;;;; Syntax Test-;;;;;+--+-- Syntax test+-- -;;;-;;; Primitive Data-;;;-(assert-equal "char literal"-  c#a-  c#a)+--+-- Primitive Data+-- -(assert-equal "string literal"-  "abc\n"-  "abc\n")+assertEqual "char literal"+  ['a', '\n', '\'']+  ['a', '\n', '\''] -(assert-equal "bool literal"-  [#t #f]-  [#t #f])+assertEqual "string literal" "" ""+assertEqual "string literal" "abc\n" "abc\n" -(assert-equal "integer literal"-  [1 0 -100 (+ 1 -100)]-  [1 0 -100 -99])+assertEqual "bool literal"+  [True, False]+  [True, False] -(assert-equal "rational number"-  [(/ 10 3) (/ 10 20) (/ -1 2)]-  [(/ 10 3) (/ 1 2) (/ -1 2)])+assertEqual "integer literal"+  [1, 0, -100, 1 - 100]+  [1, 0, -100, -99] -(assert-equal "float literal"-  [1.0 0.0 -100.012001 (+ 1.0 2)]-  [1.0 0.0 -100.012001 3.0])+assertEqual "rational number"+  [10 / 3, 10 / 20, -1 / 2]+  [10 / 3 , 1 / 2, -1 / 2] -(assert-equal "inductive data literal"-  <A>-  <A>)+assertEqual "float literal" [1.0, 0.0, -100.012001, 1.0 + 2] [1.0, 0.0, -100.012001, 3.0] -(assert-equal "tuple literal"-  [1 2 3]-  [1 2 3])+assertEqual "inductive data literal" A A -(assert-equal "singleton tuple literal"-  [1]-  1)+assertEqual "tuple literal" (1, 2, 3) (1, 2, 3) -(assert-equal "collection literal"-  {1 @{2 3 @{@{4} 5}} 6}-  {1 2 3 4 5 6})+assertEqual "collection literal" [1, 2, 3, 4, 5, 6] [1, 2, 3, 4, 5, 6] -;;;-;;; Basic Sytax-;;;-(assert-equal "if"-  (if #t #t #f)-  #t)+assertEqual "collection between" [1..5] [1, 2, 3, 4, 5]+assertEqual "collection from" (take 5 [1..]) [1, 2, 3, 4, 5] -(assert-equal "if"-  (if #f #t #f)-  #f)+assertEqual "identifier with dot and operator" (b.* 1 2) 2 -(assert-equal "let binding"-  (let {[$t [1 2]]}-    (let {[[$x $y] t]}-      (+ x y)))-  3)+--+-- Basic Sytax+-- -(assert-equal "let* binding"-  (let* {[$x 1] [$y (+ x 1)]} y)-  2)+assertEqual "if"+  (if True then True else False)+  True -(assert-equal "letrec binding"-  (letrec {[[$x $y] t]-           [$t [1 2]]}-    (+ x y))-  3)+assertEqual "if"+  (if False then True else False)+  False -(assert-equal "mutual recursion"-  (letrec {[$even? (lambda [$n]-                     (if (eq? n 0) #t (odd? (- n 1))))]-           [$odd? (lambda [$n]-                    (if (eq? n 0) #f (even? (- n 1))))]}-    (even? 10))-  #t)+assertEqual "let binding"+  (let t := (1, 2)+       (x, y) := t+    in x + y)+  3 -(assert-equal "lambda and application"-  ((lambda [$x] (+ 1 x)) 10)-  11)+assertEqual "let binding"+  (let x := 1+       y := x + 1+    in y)+  2 -(assert-equal "placeholder"-  ((+ $ 1) 10)-  11)+assertEqual "let binding without newline"+  (let { x := 1; y := x + 1 } in y)+  2 -(assert-equal "indexed placeholder"-  ((+ $1 $1) 10)-  20)+io do print "io and do expression"+      return 0 -(assert-equal "indexed placeholder2"-  ((- $2 $1) 10 20)-  10)+io do { print "io and do expression without newline"; return 0 } -;;;-;;; Pattern-Matching-;;;-(assert-equal "match"-  (match 1 integer-    {[,0 0]-     [$x (+ 10 x)]})-  11)+assertEqual "where"+  (f 0 + y + 1+    where f x := 2 + x+          y := 3)+  6 -(assert-equal "match-all"-  (match-all {1 2 3} (list integer)-    [<cons $x $xs> [x xs]])-  {[1 {2 3}]})+assertEqual "nested where"+  (f 0 + 1+    where+      f x := 2 + y + z+        where y := 3+      z := 4)+  10 -(assert-equal "match-all-multi"-  (match-all {1 2 3} (multiset integer)-    {[<cons $x <cons ,(+ x 1) _>> [x (+ x 1)]]-     [<cons $x <cons ,(+ x 2) _>> [x (+ x 2)]]})-  {[1 2] [2 3] [1 3]})+assertEqual "multiple where in one expression"+  (matchAll [1, 2, 3] as multiset integer with+   | #1 :: $xs -> f xs+     where f xs := length xs+   | #2 :: #3 :: $xs -> g xs+     where g xs := length xs)+  [2, 1] -(assert-equal "match-lambda"-  (letrec {[$count (match-lambda (list something)-                     {[<nil> 0]-                      [<cons _ $xs> (+ (count xs) 1)]})]}-    (count {1 2 3}))-  3)+assertEqual "mutual recursion"+  (let isEven n := if n = 0 then True else isOdd (n - 1)+       isOdd  n := if n = 0 then False else isEven (n - 1)+    in isEven 10)+  True -(assert-equal "match-all-lambda"-  ((match-all-lambda (list something) [<join _ <cons $x _>> x]) {1 2 3})-  {1 2 3})+assertEqual "lambda and application"+  ((\x -> x + 1) 10)+  11 -(assert-equal "match-all-lambda-multi"-  ((match-all-lambda (multiset something)-     {[<cons $x <cons ,(+ x 1) _>> [x (+ x 1)]]-      [<cons $x <cons ,(+ x 2) _>> [x (+ x 2)]]}) {1 2 3})-  {[1 2] [2 3] [1 3]})+assertEqual "application with binops"+  ((\x y -> x + y) 1 2 + 3)+  6 -(assert-equal "pattern variable"-  (match 1 something-    {[$x x]})-  1)+assertEqual "lambda with 0 argument"+  ((\() -> 1) ())+  1 -(assert "value pattern"-  (match 1 integer-    {[,1 #t]}))+assertEqual "lambda with tuple argument"+  ((\(x, y, z) -> x + y + z) 1 2 3)+  6 -(assert "and pattern"-  (match {1 2 3} (list integer)-    {[(& <cons ,1 _> <snoc ,3 _>) #t]}))+assertEqual "append op" ([1] ++ [2]) [1, 2]+assertEqual "append op" ((++) [1] [2]) [1, 2] -(assert "and pattern"-  (match {1 2 3} (list integer)-    {[(& <cons ,1 _> <cons ,3 _>) #f]-     [_ #t]}))+assertEqual "apply op" ((+ 5) $ 1 + 2) 8 -(assert "and pattern"-  (match #t something-    {[(&) #t]}))+assertEqual "section" ((+) 10 1) 11+assertEqual "section" ((+ 1) 10) 11+assertEqual "section" (foldl (*) 1 [1..5]) 120+assertEqual "section" ((-) 10 1) 9+assertEqual "section" ((10 -) 1) 9+assertEqual "section" ((10 - ) 1) 9+assertEqual "section" ((-1 +) 2) 1+assertEqual "safe section - left assoc"  ((1 + 2 +) 3) 6+assertEqual "safe section - right assoc" ((++ [1] ++ [2]) [3]) [3, 1, 2]+assertEqual "not section" (- 2) (1 - 3) -(assert "or pattern"-  (match {1 2 3} (list integer)-    {[(| <snoc ,1 _> <snoc ,3 _>) #t]}))+-- user-defined infix+infixl expression 5 @+(@) x y := x - y -(assert "or pattern"-  (match {1 2 3} (list integer)-    {[(| <cons ,2 _> <cons ,3 _>) #f]-     [_ #t]}))+assertEqual "user defined infix"+  (4 @ 3 @ 5)+  (-4) -(assert "or pattern"-  (match #t something-    {[(|) #f]-     [_ #t]}))+infixl expression 5 @@+(@@) %x y := x - y -;(assert-equal "ordered or pattern"-;  (match {1 2 3 4 5} (list integer) {[<join (|* ,{2} ,{1 2 3} ,{1}) $xs> xs]})-;  {4 5})+assertEqual "user defined infix with tensor arg"+  (4 @@ 3 @@ 2)+  (-1) -;(assert-equal "ordered or pattern"-;  (let {[$x [| 1 2 3 |]]}-;    (match-all {2 1 3} (multiset integer)-;      [<cons (& (|* !,x_1 ,x_1) $y_1)-;             <cons (& (|* !,x_2 ,x_2) $y_2)-;                   <cons (& (|* !,x_3 ,x_3) $y_3) <nil>>>> (map 1#y_%1 (between 1 3))]))-;  {{2 3 1} {3 1 2} {2 1 3} {3 2 1} {1 3 2} {1 2 3}})+findFactor :=+  memoizedLambda n ->+    match takeWhile (<= floor (sqrt (itof n))) primes as list integer with+    | _ ++ (?(\m -> divisor n m) & $x) :: _ -> x+    | _ -> n -;(assert "ordered or pattern"-;  (match {1 2 3} (list integer)-;    {[(|* <cons ,2 _> <cons ,3 _>) #f]-;     [_ #t]}))+assertEqual "memoized lambda"+  (map findFactor [1..10])+  [1, 2, 3, 2, 5, 2, 7, 2, 3, 2] -(assert "not pattern"-  (match 1 integer-    {[!,1 #f]-     [!,2 #t]}))+twinPrimes :=+  matchAll primes as list integer with+  | _ ++ $p :: #(p + 2) :: _ -> (p, p + 2) -(assert-equal "not pattern"-  (match-all {1 2 2 3 3 3} (multiset integer)-    [<cons $n !<cons ,n _>> n])-  {1})+assertEqual "twin primes"+  (take 10 twinPrimes)+  [(3, 5), (5, 7), (11, 13), (17, 19), (29, 31), (41, 43), (59, 61), (71, 73), (101, 103), (107, 109)] -(assert "predicate pattern"-  (match {1 2 3} (list integer)-    {[<cons ?(eq? 1 $) _> #t]}))+primeTriplets :=+  matchAll primes as list integer with+  | _ ++ $p :: ((#(p + 2) | #(p + 4)) & $m) :: #(p + 6) ::  _+  -> (p, m, p + 6) -(assert "predicate pattern"-  (match {1 2 3} (list integer)-    {[<cons ?(eq? 2 $) _> #f]-     [_ #t]}))+assertEqual "prime triplets"+  (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)] -(assert-equal "indexed pattern variable"-  (match 23 (mod 10) {[$a_1 a]})-  {| [1 23] |})+someFunction x y z :=+  x + y * z -(assert-equal "seq pattern"-  (match-all {1 2 3 2 4 3 5} (list integer)-    [{<join #                     <cons $x _>>-            !<join _ <cons ,x _>>             }-   x])-  {1 2 3 4 5})+assertEqual "function definition"+  (someFunction 1 2 3)+  7 -;(assert-equal "dfs pattern 1"-;  (take 10 (match-all nats (set integer)-;       [(dfs <cons $m <cons $n <cons $l _>>>) [m n l]]))-;  {[1 1 1] [1 1 2] [1 1 3] [1 1 4] [1 1 5] [1 1 6] [1 1 7] [1 1 8] [1 1 9] [1 1 10]})+someFunctionWithDollar $x $y $z :=+  x + y + z -;(assert-equal "dfs pattern 2"-;  (take 10 (match-all nats (set integer)-;       [<cons $m (dfs <cons $n <cons $l _>>)> [m n l]]))-;  {[1 1 1] [2 1 1] [3 1 1] [4 1 1] [5 1 1] [6 1 1] [7 1 1] [8 1 1] [9 1 1] [10 1 1]})+assertEqual "function definition with '$' scalar arg"+  (someFunctionWithDollar 1 2 3)+  6 -;(assert-equal "dfs pattern 3"-;  (match-all (between 1 3) (set integer)-;       [<cons $m <cons $n (dfs <cons $l _>)>> [m n l]])-;  {[1 1 1] [1 2 1] [2 1 1] [1 3 1] [2 2 1] [3 1 1] [2 3 1] [3 2 1] [3 3 1] [1 1 2] [1 2 2] [2 1 2] [1 3 2] [2 2 2] [3 1 2] [2 3 2] [3 2 2] [3 3 2] [1 1 3] [1 2 3] [2 1 3] [1 3 3] [2 2 3] [3 1 3] [2 3 3] [3 2 3] [3 3 3]})+gcd m n :=+  if m >= n then+            if n = 0 then m+                     else gcd n (m % n)+            else gcd n m -;(assert-equal "dfs and bfs pattern 1"-;  (take 10 (match-all nats (set integer)-;       [(dfs <cons $m (bfs <cons $n <cons $l _>>)>) [m n l]]))-;  {[1 1 1] [1 1 2] [1 2 1] [1 1 3] [1 2 2] [1 3 1] [1 1 4] [1 2 3] [1 3 2] [1 4 1]})+assertEqual "recursive function definition"+  (gcd 143 22)+  11 -;(assert-equal "dfs and bfs pattern 2"-;  (take 10 (match-all nats (set integer)-;       [(dfs <cons $m <cons $n (bfs <cons $l _>)>>) [m n l]]))-;  {[1 1 1] [1 1 2] [1 1 3] [1 1 4] [1 1 5] [1 1 6] [1 1 7] [1 1 8] [1 1 9] [1 1 10]})+A x := 1 -(assert "loop pattern"-  (match {3 2 1} (list integer)-    {[(loop $i [1 {3} _] <snoc ,i ...> <nil>) #t]}))+assertEqual "definition of upper-case identifier"+  (A 2)+  1 -(assert-equal "double loop pattern"-  (match {{1 2 3} {4 5 6} {7 8 9}} (list (list integer))-    {[(loop $i [1 {3} _]-        <cons (loop $j [1 {3} _]-                <cons $n_i_j ...>-                <nil>) ...>-        <nil>)-      n]})-  {|[1 {|[1 1] [2 2] [3 3]|}] [2 {|[1 4] [2 5] [3 6]|}] [3 {|[1 7] [2 8] [3 9]|}]|})+assertEqual "capply"+  (capply (+) [1, 2])+  3 -(assert-equal "let pattern"-  (match {1 2 3} (list integer)-    {[(let {[$a 42]} _) a]})-  42)+{-+  This is a comment+ -} -(assert-equal "let pattern"-  (match {1 2 3} (list integer)-    {[<cons $a (let {[$x a]} $xs)> [x xs]]})-  [1 { 2 3 }])+{-+  {- We can nest comments! -}+  {- {- nested -} comment -}+ -} -(assert-equal "let pattern"-  (match {1 2 3} (list integer)-    {[(& $a (let {[$n (length a)]} _)) [a n]]})-  [{1 2 3} 3])+--+-- Pattern-Matching+-- -(assert-equal "tuple patterns"-  (match-all [1 [2 3]] [integer [integer integer]]-    [[$m [$n $w]] [m n w]])-  {[1 2 3]})+assertEqual "match"+  (match 1 as integer with+   | #0 -> 0+   | $x -> 10 + x)+  11 -(assert-equal "pattern function call"-  (letrec {[$twin (pattern-function [$pat1 $pat2]-                    <cons (& pat1 $x) <cons ,x pat2>>)-            ]}-    (match {1 1 1 2 3} (list integer)-      {[(twin $n $ns) [n ns]]}))-  [1 {1 2 3}])+assertEqual "match-all"+  (matchAll [1, 2, 3] as multiset integer with+   | $x :: _ -> x)+  [1, 2, 3] -(assert-equal "recursive pattern function call"-  (letrec {[$repeat (pattern-function [$pat]-                      (| <nil>-                         <cons (& pat $x) (repeat ,x)>))-            ]}-    (match {1 1 1 1} (list integer)-      {[(repeat $n) n]}))-  1)+assertEqual "match-all-multi"+  (matchAll [1, 2, 3] as multiset integer with+   | $x :: #(x + 1) :: _ -> [x, x + 1]+   | $x :: #(x + 2) :: _ -> [x, x + 2])+  [[1, 2], [2, 3], [1, 3]] -(assert-equal "loop pattern in pattern function"-  (letrec {[$comb (lambda [$n]-                    (pattern-function [$p]-                      (loop $i [1 {n} _]-                        <join _ <cons p_i ...>>-                        _)))-           ]}-    (match-all {1 2 3 4 5} (list integer)-      [((comb 2) $n) n]))-  {{|[1 1] [2 2]|} {|[1 1] [2 3]|} {|[1 2] [2 3]|} {|[1 1] [2 4]|} {|[1 2] [2 4]|} {|[1 3] [2 4]|} {|[1 1] [2 5]|} {|[1 2] [2 5]|} {|[1 3] [2 5]|} {|[1 4] [2 5]|}})+assertEqual "match-lambda"+  ((\match as list integer with+    | [] -> 0+    | $x :: _ -> x) [1, 2, 3])+  1 -(assert-equal "pairs of 2 natural numbers"-  (take 10 (match-all nats (set integer)-             [<cons $m <cons $n _>> [m n]]))-  {[1 1] [1 2] [2 1] [1 3] [2 2] [3 1] [1 4] [2 3] [3 2] [4 1]})+assertEqual "match-all-lambda"+  ((\matchAll as list something with+    | _ ++ $x :: _ -> x) [1, 2, 3])+  [1, 2, 3] -(assert-equal "pairs of 2 different natural numbers"-  (take 10 (match-all nats (list integer)-             [<join _ <cons $m <join _ <cons $n _>>>> [m n]]))-  {[1 2] [1 3] [2 3] [1 4] [2 4] [3 4] [1 5] [2 5] [3 5] [4 5]})+assertEqual "match-all-lambda-multi"+  ((\matchAll as multiset something with+    | $x :: #(x + 1) :: _ -> [x, x + 1]+    | $x :: #(x + 2) :: _ -> [x, x + 2]) [1, 2, 3])+  [[1, 2], [2, 3], [1, 3]] -(define $tree-  (lambda [$a]-    (algebraic-data-matcher-      {<leaf> <node (tree a) a (tree a)>})))+assert "nested pattern match"+  (match [1, 2, 3] as list integer with+   | #2 :: $x -> match x as multiset integer with+                | _ -> False+   | #1 :: $x -> match x as multiset integer with+                | #1 :: _ -> False+                | #2 :: _ -> True) -(define $tree-insert-  (lambda [$n $t]-    (match t (tree integer)-      {[<leaf> <Node <Leaf> n <Leaf>>]-       [<node $t1 $m $t2>-        (match (compare n m) ordering-          {[<less> <Node (tree-insert n t1) m t2>]-           [<equal> <Node t1 n t2>]-           [<greater> <Node t1 m (tree-insert n t2)>]})]})))+assertEqual "pattern variable"+  (match 1 as something with $x -> x)+  1 -(define $tree-member?-  (lambda [$n $t]-    (match t (tree integer)-      {[<leaf> #f]-       [<node $t1 $m $t2>-        (match (compare n m) ordering-          {[<less> (tree-member? n t1)]-           [<equal> #t]-           [<greater> (tree-member? n t2)]})]})))+assert "value pattern" (match 1 as integer with #1 -> True) -(assert-equal "tree set using algebraic-data-matcher"-  (let {[$t (foldr tree-insert <Leaf> {4 1 2 4 3})]}-    [(tree-member? 1 t) (tree-member? 0 t)])-  [#t #f])+assert "inductive pattern"+  (match [1, 2, 3] as list integer with+   | snoc #3 _ -> True) -(assert-equal "tuple pattern"-  (match-all {[1 1] [2 2]} (multiset [integer integer]) [<cons [$x ,x] _> x])-  {1 2})+assert "collection pattern - nil"+  (match [] as list integer with+   | [] -> True) +assertEqual "collection pattern"+  (match [1, 2, 3] as list integer with+   | [#1, _, $x] -> x)+  3 -;;;-;;; Array-;;;+assertEqual "collection pattern"+  (matchAll [1, 2, 3, 4] as list integer with+   | [_, _, _] -> True)+  [] -(assert-equal "array-literal"-  (| 1 2 3 4 5 |)-  (| 1 2 3 4 5 |)-  )+assert "and pattern"+  (match [1, 2, 3] as list integer with+   | #1 :: _ & snoc #3 _ -> True) -(assert-equal "empty array literal"-  (||)-  (||)-  )+assert "and pattern"+  (match [1, 2, 3] as list integer with+   | #1 :: _ & #3 :: _ -> False+   | _ -> True) -(assert-equal "generate-array"-  (generate-array (+ $ 100) [3 5])_4-  104-  )+assert "or pattern"+  (match [1, 2, 3] as list integer with+   | snoc #1 _ | snoc #3 _ -> True) -(assert-equal "array-bounds - case 1"-  (array-bounds (| 1 2 3 |))-  [1 3]-  )+assert "or pattern"+  (match [1, 2, 3] as list integer with+   | #2 :: _ | #1 :: _ -> True) -(assert-equal "array-bounds - case 2"-  (array-bounds (generate-array (+ $ 100) [3 5]))-  [3 5]-  )+assert "not pattern"+  (match [1, 2] as list integer with+   | snoc !#1 _ -> True+   | !#1 :: _ -> False) -(assert-equal "array-ref"-  (array-ref (| 1 2 3 4 5 |) 3)-  3)+assertEqual "not pattern"+  (matchAll [1, 2, 2, 3, 3, 3] as multiset integer with+   | $n :: !(#n :: _) -> n)+  [1] -;;;-;;; Tensor-;;;-(assert-equal "generate-tensor - case 1"-  (generate-tensor kronecker-delta {3})-  [| 1 1 1 |])+assert "predicate pattern"+  (match [1, 2, 3] as list integer with+   | ?(= 1) :: _ -> True) -(assert-equal "generate-tensor - case 2"-  (generate-tensor kronecker-delta { 2 2 2 2 })-  (tensor {2 2 2 2} {1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1} ))+assert "predicate pattern"+  (match [1, 2, 3] as list integer with+   | ?(= 2) :: _ -> False+   | _ -> True) -;;;-;;; Hash-;;;-(assert-equal "hash-literal"-  {| [1 11] [2 12] [3 13] [4 14] [5 15] |}-  {| [1 11] [2 12] [3 13] [4 14] [5 15] |}-  )+assertEqual "indexed pattern variable"+  (match 23 as mod 10 with+   | $a_1 -> a)+  {| (1, 23) |} -(assert-equal "empty hash-literal"+assert "loop pattern"+  (match [3, 2, 1] as list integer with+   | loop $i (1, [3], _)+       (snoc #i ...)+       [] -> True)++assertEqual "loop pattern"+  (match [1..10] as list integer with+   | loop $i (1, $n)+       (#i :: ...)+       [] -> n)+  10++assert "loop pattern"+  (match [3, 2, 1] as list integer with+   | loop $i (1, [3], _)+       (snoc #i ...)+       [] -> True)++assertEqual "double loop pattern"+  (match [[1, 2, 3], [4, 5, 6], [7, 8, 9]] as (list (list integer)) with+   | loop $i (1, [3], _)+       ((loop $j (1, [3], _)+           ($n_i_j :: ...)+           []) :: ...)+       [] -> n)+  {| (1, {| (1, 1), (2, 2), (3, 3) |}),+     (2, {| (1, 4), (2, 5), (3, 6) |}),+     (3, {| (1, 7), (2, 8), (3, 9) |}) |}++assertEqual "let pattern"+  (match [1, 2, 3] as list integer with+   | let a := 42 in _ -> a)+  42++assertEqual "let pattern"+  (match [1, 2, 3] as list integer with+   | $a :: (let x := a in $xs) -> [x, xs])+  [1, [2, 3]]++assertEqual "let pattern"+  (match [1, 2, 3] as list integer with+   | $a & (let n := length a in _) -> [a, n])+  [[1, 2, 3], 3]++assertEqual "tuple pattern"+  (matchAll (1, (2, 3)) as (integer, (integer, integer)) with+   | ($m, ($n, $w)) -> [m, n, w])+  [[1, 2, 3]]++assertEqual "tuple pattern"+  (matchAll [(1, 1), (2, 2)] as multiset (integer, integer) with+   | ($x, #x) :: _ -> x)+  [1, 2]++assertEqual "pattern function call"+   (let twin := \pat1 pat2 => (~pat1 & $x) :: #x :: ~pat2 in+    match [1, 1, 1, 2, 3] as list integer with+    | twin $n $ns -> [n, ns])+   [1, [1, 2, 3]]++assertEqual "recursive pattern function call"+  (let repeat := \pat => [] | ~pat :: (repeat ~pat) in+   matchAll [1, 1, 1, 1] as list integer with+   | repeat #1 -> "OK")+  ["OK"]++assertEqual "loop pattern in pattern function"+  (let comb n := \p =>+     loop $i (1, n, _) (_ ++ ~p_i :: ...) _+    in+    matchAll [1, 2, 3, 4, 5] as (list integer) with+    | (comb 2) $n -> n)+  [{|(1, 1), (2, 2)|}, {|(1, 1), (2, 3)|},+   {|(1, 2), (2, 3)|}, {|(1, 1), (2, 4)|},+   {|(1, 2), (2, 4)|}, {|(1, 3), (2, 4)|},+   {|(1, 1), (2, 5)|}, {|(1, 2), (2, 5)|},+   {|(1, 3), (2, 5)|}, {|(1, 4), (2, 5)|}]++assertEqual "pairs of 2, natural numbers"+  (take 10 (matchAll nats as set integer with+            | $m :: $n :: _ -> [m, n]))+  [[1, 1], [1, 2], [2, 1], [1, 3], [2, 2], [3, 1], [1, 4], [2, 3], [3, 2], [4, 1]]++assertEqual "pairs of 2, different natural numbers"+  (take 10 (matchAll nats as list integer with+            | _ ++ $m :: _ ++ $n :: _ -> [m, n]))+  [[1, 2], [1, 3], [2, 3], [1, 4], [2, 4], [3, 4], [1, 5], [2, 5], [3, 5], [4, 5]]++assertEqual "combinations"+  (matchAll [1,2,3] as list something with+   | _ ++ $x :: _ ++ $y :: _ -> (x, y))+  [(1, 2), (1, 3), (2, 3)]++assertEqual "permutations"+  (matchAll [1,2,3] as multiset something with+   | $x :: $y :: _ -> (x, y))+  [(1, 2), (1, 3), (2, 1), (2, 3), (3, 1), (3, 2)]++tree a := algebraicDataMatcher+  | leaf+  | node (tree a) a (tree a)++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+      | less    -> Node (treeInsert n t1) m t2+      | equal   -> Node t1 n t2+      | greater -> Node t1 m (treeInsert n t2)++treeMember n t :=+  match t as tree integer with+  | leaf -> False+  | node $t1 $m $t2 -> match (compare n m) as ordering with+      | less    -> treeMember n t1+      | equal   -> True+      | greater -> treeMember n t2++assertEqual "tree set using algebraic-data-matcher"+  (let t := foldr treeInsert Leaf [4, 1, 2, 4, 3]+    in [treeMember 1 t, treeMember 0 t])+  [True, False]++assert "sequential pattern"+  (match [2,3,1,4,5] as list integer with+   | { @ :: @ :: $x :: _,+       (#(x + 1), @),+      #(x + 2)}+   -> True)++assertEqual "sequential not pattern"+  (matchAll ([1,2,3], [4,3,5]) as (multiset eq, multiset eq) with+   | { ($x :: @, #x :: @),+       !($y :: _, #y :: _) }+   -> x)+  [3]++assertEqual "partial sequential pattern"+  (matchAll ([1,2,3,2], [10,20]) as (list eq, list eq) with+   | ({ @ ++ $x :: _, !(_ ++ #x :: _) }, $ys) -> (x, ys))+  [(1, [10, 20]), (2, [10, 20]), (3, [10, 20])]++assertEqual "forall pattern 1"+  (matchAll [1,5,3] as multiset integer with+   | forall _ _ -> "ok")+  ["ok"]++assertEqual "forall pattern 2"+  (matchAll [1,5,3] as multiset integer with+   | (forall ((@ & $x) :: _) ?isOdd) & $xs -> (x,xs))+  [(1, [1, 5, 3]), (5, [1, 5, 3]), (3, [1, 5, 3])]++assertEqual "forall pattern 3"+  (matchAllDFS [1,5,3] as multiset integer with+   | forall ((@ & $x) :: _) ?isOdd -> x)+  [1,5,3]++assertEqual "forall pattern 4"+  (matchAll [1,5,3] as multiset integer with+   | forall ((@ & $x) :: _) ?isOdd -> x)+  [1, 5, 3]++--+-- Tensor+--++assertEqual "generate-tensor"+  (generateTensor (*) [3, 5])+  [| [| 1, 2, 3, 4, 5 |], [| 2, 4, 6, 8, 10 |], [| 3, 6, 9, 12, 15 |] |]++assertEqual "tensor"+  (tensor [2, 5] [1, 2, 3, 4, 5, 2, 4, 6, 8, 10])+  [| [| 1, 2, 3, 4, 5 |], [| 2, 4, 6, 8, 10 |] |]++assertEqual "tensor wedge expr"+  (! min [| 1, 2, 3 |] [| 1, 2, 3 |])+  [| [| 1, 1, 1 |], [| 1, 2, 2 |], [| 1, 2, 3 |] |]++assertEqual "tensor wedge expr of binary operator"+  ([| 1, 2, 3 |] !+ [| 1, 2, 3 |])+  [| [| 2, 3, 4 |], [| 3, 4, 5 |], [| 4, 5, 6 |] |]++assertEqual "tensor wedge expr of binary operator - section style"+  ((!+) [| 1, 2, 3 |] [| 1, 2, 3 |])+  [| [| 2, 3, 4 |], [| 3, 4, 5 |], [| 4, 5, 6 |] |]++assertEqual "tensor multiplication"+  ([| 1, 2, 3 |]_i * [| 1, 2, 3 |]_i)+  [| 1, 4, 9 |]_i++assertEqual "multi subscript"+  (let i := {| (1, 1), (2, 2), (3, 3) |}+       x := generateTensor (\x y z -> x + y + z) [5, 5, 5]+    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++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] )_#_#_#++--+-- Hash+--++assertEqual "hash-literal"+  {| (1, 11), (2, 12), (3, 13), (4, 14), (5, 15), |}+  {| (1, 11), (2, 12), (3, 13), (4, 14), (5, 15), |}++assertEqual "empty hash-literal"   {| |}   {| |}-  ) -(assert-equal "hash access"-  {| [1 11] [2 12] [3 13] [4 14] [5 15] |}_3+assertEqual "hash access"+  {| (1, 11), (2, 12), (3, 13), (4, 14), (5, 15), |}_3   13-  ) -;(assert-equal "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 -;;;-;;; Partial Application-;;;-(assert-equal "partial application '$'"-  ((+ $ $) 1 2)-  3)+--+-- Partial Application+-- -(assert-equal "partial application '$' with index"-  ((- $2 $1) 1 2)-  1)+assertEqual "partial application '#'"+  (2#(10 * %1 + %2) 1 2)+  12 -(assert-equal "partial application '#'"-  (2#(+ (* 10 %1) %2) 1 2)-  12)+assertEqual "recursive partial application '#'"+  (take 10 (1#(%1 :: (%0 (%1 * 2))) 2))+  [2, 4, 8, 16, 32, 64, 128, 256, 512, 1024] -(assert-equal "recursive partial application '#'"-  (take 10 (1#{%1 @(%0 (* %1 2))} 2))-  {2 4 8 16 32 64 128 256 512 1024})+f *x *y := x + y -(assert-equal "double inverted index"-  (let {[$f (lambda [*$x *$y] (+ x y))]}-    [(f [|1 2 3|]_i [|10 20 30|]_j)])-  [[| [| 11 21 31 |] [| 12 22 32 |] [| 13 23 33 |] |]~i~j])+assertEqual "double inverted index"+  (f [|1, 2, 3|]_i [|10, 20, 30|]_j)+  [| [| 11, 21, 31, |], [| 12, 22, 32, |], [| 13, 23, 33, |], |]~i~j -(assert-equal "single inverted index"-  (let {[$f (lambda [$x *$y] (+ x y))]}-    [(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 +assertEqual "single inverted index"+  (g [|1, 2, 3|]_i  [|10, 20, 30|]_j)+  [| [| 11, 21, 31, |], [| 12, 22, 32, |], [| 13, 23, 33, |], |]_i~j++--+-- matcherExpr+--++list a := matcher+  | [] as () with+    | [] -> [()]+    | _  -> []+  | $ :: $    as (a, list a) with+    | $x :: $xs -> [(x, xs)]+    | _         -> []+  | snoc $ $ as (a, list a) with+    | snoc $xs $x -> [(x, xs)]+    | _           -> []+  | _ ++ $ as (list a) with+    | $tgt -> matchAll tgt as list a with+              | loop $i (1, _) (_ :: ...) $rs -> rs+  | $ ++ $ as (list a, list a) with+    | $tgt -> matchAll tgt as list a with+              | loop $i (1, $n) ($xa_i :: ...) $rs ->+                (foldr (\%i %r -> xa_i :: r) [] [1..n], rs)+  | nioj $ $ as (list a, list a) with+    | $tgt -> matchAll tgt as list a with+              | loop $i (1, $n) (snoc $xa_i ...) $rs ->+                (foldr (\%i %r -> r ++ [xa_i]) [] [1..n], rs)+  | #$val as () with+    | $tgt -> if val = tgt then [()] else []+  | $ as something with+    | $tgt -> [tgt]++multiset a := matcher+  | [] as () with+    | $tgt -> match tgt as (mutiset a) with+                | [] -> [()]+                | _ -> []+  | $ :: $ as (a, multiset a) with+    | $tgt -> matchAll tgt as list a with+                | $hs ++ $x :: $ts -> (x, hs ++ ts)+  | #$val as () with+    | $tgt -> match (val, tgt) as (list a, multiset a) with+                | ([], []) -> [()]+                | ($x :: $xs, #x :: #xs) -> [()]+                | (_, _) -> []+  | $ as something with+    | $tgt -> [tgt]++assertEqual "matcher definition"+  (matchAll [1, 2, 3] as multiset integer with+   | $x :: _ -> x)+  [1, 2, 3]++nishiwakiIf b e1 e2 :=+  head (matchAll b as (matcher+                      | $ as something with+                          | True  -> [e1]+                          | False -> [e2]) with+       | $x -> x)++assertEqual "case 1" (nishiwakiIf True     1 2) 1+assertEqual "case 2" (nishiwakiIf False    1 2) 2+assertEqual "case 3" (nishiwakiIf (1 = 1) 1 2) 1++-- User-defined pattern infix++infixl pattern 7 <>+infixl pattern 4 <?> -- '?' is allowed from the 2nd character++dummyMatcher := matcher+  | $ <> $ as (integer, integer) with+    | $x :: $y :: [] -> [(x, y)]+    | _              -> []+  | $ <?> $ as (integer, list integer) with+    | $x :: $xs -> [(x, xs)]+    | _         -> []++assertEqual "user-defined pattern infix"+  (match [1, 2] as dummyMatcher with $x <> $y -> x + y)+  3++assertEqual "user-defined pattern infix"+  (match [1, 2] as dummyMatcher with $x <?> $y :: _ -> x + y)+  3