egison 3.10.2 → 3.10.3

raw patch · 47 files changed

+3534/−1545 lines, 47 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• benchmark/Benchmark.hs +1/−0
• egison.cabal +5/−3
• elisp/egison-mode.el +32/−140
• hs-src/Interpreter/egison.hs +1/−1
• hs-src/Language/Egison.hs +2/−3
• hs-src/Language/Egison/AST.hs +50/−33
• hs-src/Language/Egison/CmdOptions.hs +0/−1
• hs-src/Language/Egison/Core.hs +127/−94
• hs-src/Language/Egison/Data.hs +846/−0
• hs-src/Language/Egison/Desugar.hs +38/−17
• hs-src/Language/Egison/MathExpr.hs +16/−9
• hs-src/Language/Egison/MathOutput.hs +0/−1
• hs-src/Language/Egison/Parser.hs +18/−33
• hs-src/Language/Egison/ParserNonS.hs +265/−147
• hs-src/Language/Egison/Pretty.hs +264/−70
• hs-src/Language/Egison/Primitives.hs +8/−8
• hs-src/Language/Egison/Tensor.hs +42/−54
• hs-src/Language/Egison/Types.hs +23/−850
• hs-src/Language/Egison/Util.hs +0/−1
• hs-src/Tool/translator.hs +96/−23
• lib/core/base.egi +5/−1
• lib/core/collection.egi +2/−2
• lib/core/sexpr.egi +15/−0
• lib/math/algebra/matrix.egi +12/−12
• lib/math/algebra/tensor.egi +3/−3
• lib/math/analysis/derivative.egi +1/−1
• lib/math/common/arithmetic.egi +1/−1
• nons-sample/math/geometry/curvature-form.egi +32/−0
• nons-sample/math/geometry/hodge-laplacian-polar.egi +37/−0
• nons-test/test/lib/core/collection.egi +331/−0
• nons-test/test/lib/core/number.egi +118/−0
• nons-test/test/lib/core/string.egi +69/−0
• nons-test/test/lib/math/algebra.egi +21/−0
• nons-test/test/lib/math/analysis.egi +37/−0
• nons-test/test/lib/math/arithmetic.egi +22/−0
• nons-test/test/lib/math/tensor.egi +73/−0
• nons-test/test/syntax.egi +101/−27
• sample/math/analysis/vector-analysis.egi +1/−1
• sample/sat/cdcl-debug.egi +155/−0
• sample/sat/cdcl.egi +147/−0
• sample/sat/dp.egi +41/−0
• sample/sat/dp2.egi +43/−0
• sample/sat/dp3.egi +53/−0
• sample/sat/dpll.egi +363/−0
• test/Test.hs +6/−8
• test/lib/core/collection.egi +10/−0

@@ -1,4 +1,4 @@-Copyright (c) 2011-2019, Satoshi Egi+Copyright (c) 2011-2020, Satoshi Egi  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"),

@@ -7,6 +7,7 @@ import           Criterion import           Criterion.Main import           Language.Egison+import           Language.Egison.CmdOptions  runEgisonFile :: String -> IO () runEgisonFile path = initialEnv defaultOption >>= flip (loadEgisonFile defaultOption) path >> return ()

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.10.2+Version:             3.10.3 Synopsis:            Programming language with non-linear pattern-matching against non-free data Description:   An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language.@@ -60,9 +60,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/io/*.egi sample/math/algebra/*.egi sample/math/analysis/*.egi sample/math/geometry/*.egi sample/math/number/*.egi sample/math/others/*.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                      test/*.egi test/lib/core/*.egi test/lib/math/*.egi-                     nons-test/test/*.egi nons-test/test/lib/core/*.egi+                     nons-test/test/*.egi nons-test/test/lib/core/*.egi nons-test/test/lib/math/*.egi                      elisp/egison-mode.el  @@ -103,6 +104,7 @@                    Language.Egison.Core                    Language.Egison.CmdOptions                    Language.Egison.Desugar+                   Language.Egison.Data                    Language.Egison.Types                    Language.Egison.Tensor                    Language.Egison.Parser

@@ -38,48 +38,29 @@ (defconst egison-font-lock-keywords-1   (eval-when-compile     (list-     "\\<module\\>"-     "\\<define\\>"-     "\\<redefine\\>"-     "\\<set!\\>"-     "\\<test\\>"-     "\\<execute\\>"      "\\<load\\>"-     "\\<load-file\\>"+     "\\<loadFile\\>" -     "\\<lambda\\>"-     "\\<memoized-lambda\\>"-     "\\<memoize\\>"-     "\\<cambda\\>"-     "\\<procedure\\>"-     "\\<macro\\>"      "\\<let\\>"-     "\\<letrec\\>"-     "\\<let\\*\\>"-     "\\<with-symbols\\>"+     "\\<withSymbols\\>"      "\\<if\\>"-     "\\<seq\\>"-;     "\\<apply\\>"-     "\\<capply\\>"-     "\\<generate-array\\>"-     "\\<array-bounds\\>"-     "\\<array-ref\\>"+     "\\<generateArray\\>"+     "\\<arrayBounds\\>"+     "\\<arrayRef\\>"      "\\<tensor\\>"-     "\\<generate-tensor\\>"+     "\\<generateTensor\\>"      "\\<contract\\>"-     "\\<tensor-map\\>"+     "\\<tensorMap\\>"       "\\<loop\\>"      "\\<match\\>"-     "\\<match-dfs\\>"-     "\\<match-lambda\\>"-     "\\<match-all\\>"-     "\\<match-all-dfs\\>"-     "\\<match-all-lambda\\>"+     "\\<matchDFS\\>"+     "\\<matchAll\\>"+     "\\<matchAllDFS\\>"+     "\\<as\\>"+     "\\<with\\>"      "\\<matcher\\>"-     "\\<self\\>"-     "\\<algebraic-data-matcher\\>"-     "\\<pattern-function\\>"+     "\\<algebraicDataMatcher\\>"       "\\<do\\>"      "\\<io\\>"@@ -88,8 +69,12 @@      "\\<undefined\\>"      "\\<something\\>" +;     ":="+     "::"+     "++"      "\\\.\\\.\\\."-     "\\\,"+     "->"+     "#" ;     "'"      "`"      "\\\#"@@ -97,6 +82,7 @@      "\\\&"      "@"      "!"+     "?" ;     "\\<_\\>"       "\\<assert\\>"@@ -116,104 +102,10 @@ (defvar egison-font-lock-keywords egison-font-lock-keywords-1   "Default expressions to highlight in Egison modes.") --(defun egison-open-paren-p ()-  (let ((c (string-to-char (thing-at-point 'char))))-    (or (eq c 40) (eq c 60) (eq c 91) (eq c 123))))--(defun egison-close-paren-p ()-  (let ((c (string-to-char (thing-at-point 'char))))-    (or (eq c 41) (eq c 62) (eq c 93) (eq c 125))))--(defun egison-last-unclosed-paren ()-  (save-excursion-    (let ((pc 0))-      (while (<= pc 0)-        (if (bobp)-            (setq pc 2)-          (backward-char)-          (if (egison-open-paren-p)-              (progn-                (setq pc (+ pc 1))-                (if (and (= pc 0) (= (current-column) 0))-                    (setq pc 2)))-            (if (egison-close-paren-p)-                (setq pc (- pc 1))))))-      (if (= pc 2)-          nil-        (point)))))--(defun egison-indent-point ()-  (save-excursion-    (beginning-of-line)-    (let ((p (egison-last-unclosed-paren)))-      (if p-          (progn-            (goto-char (egison-last-unclosed-paren))-            (let ((cp (current-column)))-              (cond ((eq (string-to-char (thing-at-point 'char)) 40)-                     (forward-char)-                     (let* ((op (current-word))-                            (ip (egison-keyword-indent-point op)))-                       (if ip-                           (+ ip cp)-                         (progn (forward-sexp)-                                (+ 1 (current-column))))))-                    ((eq (string-to-char (thing-at-point 'char)) 60)-                     (forward-char)-                     (let ((op (current-word)))-                       (+ 2 (length op) cp)))-                    ((eq (string-to-char (thing-at-point 'char)) 91)-                     (forward-char)-                     (if (eq (string-to-char (thing-at-point 'char)) 124)-                         (+ 2 cp)-                       (+ 1 cp)))-                    (t (+ 1 cp)))))-        0))))--(defun egison-keyword-indent-point (name)-  (cond ((equal "module" name) 2)-        ((equal "define" name) 2)-        ((equal "test" name) 2)-        ((equal "load" name) 2)-        ((equal "load-file" name) 2)-        ((equal "execute" name) 2)-        ((equal "lambda" name) 2)-        ((equal "cambda" name) 2)-        ((equal "procedure" name) 2)-        ((equal "macro" name) 2)-        ((equal "memoized-lambda" name) 2)-        ((equal "memoize" name) 2)-        ((equal "letrec" name) 2)-        ((equal "let" name) 2)-        ((equal "let*" name) 2)-        ((equal "with-symbols" name) 2)-        ((equal "if" name) 2)-        ((equal "apply" name) 2)-        ((equal "generate-array" name) 2)-        ((equal "array-ref" name) 2)-        ((equal "generate-tensor" name) 2)-        ((equal "tensor-map" name) 2)-        ((equal "loop" name) 2)-        ((equal "match" name) 2)-        ((equal "match-dfs" name) 2)-        ((equal "match-lambda" name) 2)-        ((equal "match-all" name) 2)-        ((equal "match-all-dfs" name) 2)-        ((equal "match-all-lambda" name) 2)-        ((equal "matcher" name) 2)-        ((equal "algebraic-data-matcher" name) 2)-        ((equal "pattern-function" name) 2)-        ((equal "do" name) 2)-        ((equal "io" name) 2)-        ((equal "assert" name) 2)-        ((equal "assert-equal" name) 2)-        ))- (defun egison-indent-line ()   "indent current line as Egison code."   (interactive)-  (indent-line-to (egison-indent-point)))+  )   (defvar egison-mode-map@@ -224,15 +116,15 @@   (defvar egison-mode-syntax-table-  (let ((egison-mode-syntax-table (make-syntax-table)))-    (modify-syntax-entry ?< "(>" egison-mode-syntax-table)-    (modify-syntax-entry ?> ")<" egison-mode-syntax-table)-    (modify-syntax-entry ?\; "<" egison-mode-syntax-table)-    (modify-syntax-entry ?\n ">" egison-mode-syntax-table)-    (modify-syntax-entry ?\? "w" egison-mode-syntax-table)-    (modify-syntax-entry ?# ". 14bn" egison-mode-syntax-table)-    ;(modify-syntax-entry ?| ". 23bn" egison-mode-syntax-table)-    egison-mode-syntax-table)+  (let ((table (make-syntax-table)))++    (modify-syntax-entry ?\{  "(}1nb" table)+    (modify-syntax-entry ?\}  "){4nb" table)+    (modify-syntax-entry ?-  "_ 123" table)+    (modify-syntax-entry ?\-  "_ 123" table)+;    (modify-syntax-entry ?\;  "_ 123" table)+    (modify-syntax-entry ?\n ">" table)+    table)   ;; (copy-syntax-table lisp-mode-syntax-table)   "Syntax table for Egison mode") @@ -241,12 +133,12 @@   (set (make-local-variable 'font-lock-defaults)        '((egison-font-lock-keywords           egison-font-lock-keywords-1 egison-font-lock-keywords-2)-         nil t (("+-*/=!?%:_~.'∂∇α-ωΑ-Ω" . "w") ("<" . "(") (">" . ")"))+         nil t (("+*/=!?%:_~.'∂∇αβγδεζχθικλμνξοπρςστυφχψωΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩ" . "w"))          ))   (set (make-local-variable 'indent-line-function) 'egison-indent-line)-  (set (make-local-variable 'comment-start) ";")+  (set (make-local-variable 'comment-start) "--")   (set (make-local-variable 'comment-end) "")-  (set (make-local-variable 'comment-start-skip) ";+ *")+  (set (make-local-variable 'comment-start-skip) "{-+ *\\|--+ *")   (set (make-local-variable 'comment-add) 1)   (set (make-local-variable 'comment-end-skip) nil)   )

@@ -77,7 +77,7 @@  showBanner :: IO () showBanner = do-  putStrLn $ "Egison Version " ++ showVersion version ++ " (C) 2011-2019 Satoshi Egi"+  putStrLn $ "Egison Version " ++ showVersion version   putStrLn $ "https://www.egison.org"   putStrLn $ "Welcome to Egison Interpreter!" --  putStrLn $ "** Information **"

@@ -2,7 +2,6 @@  {- | Module      : Language.Egison-Copyright   : Satoshi Egi Licence     : MIT  This is the top module of Egison.@@ -10,7 +9,7 @@  module Language.Egison        ( module Language.Egison.AST-       , module Language.Egison.Types+       , module Language.Egison.Data        , module Language.Egison.Primitives        -- * Eval Egison expressions        , evalTopExprs@@ -37,11 +36,11 @@ import           Language.Egison.AST import           Language.Egison.CmdOptions import           Language.Egison.Core+import           Language.Egison.Data import           Language.Egison.MathOutput  (changeOutputInLang) import           Language.Egison.Parser      as Parser import           Language.Egison.ParserNonS  as ParserNonS import           Language.Egison.Primitives-import           Language.Egison.Types  import           Control.Monad.State 

@@ -5,7 +5,6 @@  {- | Module      : Language.Egison.AST-Copyright   : Satoshi Egi Licence     : MIT  This module defines the syntax of Egison.@@ -29,9 +28,10 @@   , LoopRange (..)   , PrimitivePatPattern (..)   , PrimitiveDataPattern (..)-  , EgisonBinOp (..)+  , Infix (..)   , BinOpAssoc (..)-  , reservedBinops+  , reservedExprInfix+  , reservedPatternInfix   , stringToVar   , stringToVarExpr   ) where@@ -51,6 +51,7 @@     -- temporary : we will replace load to import and export   | LoadFile String   | Load String+  | InfixDecl Bool Infix -- True for pattern infix; False for expression infix  deriving (Show, Eq)  data EgisonExpr =@@ -102,7 +103,8 @@   | IoExpr EgisonExpr    | UnaryOpExpr String EgisonExpr-  | BinaryOpExpr EgisonBinOp EgisonExpr EgisonExpr+  | BinaryOpExpr Infix EgisonExpr EgisonExpr+  | SectionExpr Infix (Maybe EgisonExpr) (Maybe EgisonExpr) -- There cannot be 'SectionExpr op (Just _) (Just _)'    | SeqExpr EgisonExpr EgisonExpr   | ApplyExpr EgisonExpr EgisonExpr@@ -115,12 +117,12 @@   | ArrayRefExpr EgisonExpr EgisonExpr    | GenerateTensorExpr EgisonExpr EgisonExpr-  | TensorExpr EgisonExpr EgisonExpr EgisonExpr EgisonExpr+  | TensorExpr EgisonExpr EgisonExpr   | TensorContractExpr EgisonExpr EgisonExpr   | TensorMapExpr EgisonExpr EgisonExpr   | TensorMap2Expr EgisonExpr EgisonExpr EgisonExpr   | TransposeExpr EgisonExpr EgisonExpr-  | FlipIndicesExpr EgisonExpr+  | FlipIndicesExpr EgisonExpr                              -- Does not appear in user program    | FunctionExpr [EgisonExpr] @@ -177,15 +179,18 @@   | PredPat EgisonExpr   | IndexedPat EgisonPattern [EgisonExpr]   | LetPat [BindingExpr] EgisonPattern+  | InfixPat Infix EgisonPattern EgisonPattern -- Includes AndPat,OrPat,InductivePat(cons/join)   | NotPat EgisonPattern   | AndPat [EgisonPattern]   | OrPat [EgisonPattern]+  | ForallPat EgisonPattern EgisonPattern   | TuplePat [EgisonPattern]   | InductivePat String [EgisonPattern]   | LoopPat Var LoopRange EgisonPattern EgisonPattern   | ContPat   | PApplyPat EgisonExpr [EgisonPattern]   | VarPat String+  | InductiveOrPApplyPat String [EgisonPattern]   | SeqNilPat   | SeqConsPat EgisonPattern EgisonPattern   | LaterPatVar@@ -219,13 +224,13 @@   | PDConstantPat EgisonExpr  deriving (Show, Eq) -data EgisonBinOp-  = EgisonBinOp { repr     :: String  -- syntastic representation-                , func     :: String  -- semantics-                , priority :: Int-                , assoc    :: BinOpAssoc-                , isWedge  :: Bool    -- True if operator is prefixed with '!'-                }+data Infix+  = Infix { repr     :: String  -- syntastic representation+          , func     :: String  -- semantics+          , priority :: Int+          , assoc    :: BinOpAssoc+          , isWedge  :: Bool    -- True if operator is prefixed with '!'. Only used for expression infix.+          }   deriving (Eq, Ord, Show)  data BinOpAssoc@@ -239,28 +244,40 @@   show RightAssoc = "infixr"   show NonAssoc   = "infix" -reservedBinops :: [EgisonBinOp]-reservedBinops =-  [ makeBinOp "^"  "**"        8 LeftAssoc-  , makeBinOp "*"  "*"         7 LeftAssoc-  , makeBinOp "/"  "/"         7 LeftAssoc-  , makeBinOp "."  "."         7 LeftAssoc -- tensor multiplication-  , makeBinOp "%"  "remainder" 7 LeftAssoc-  , makeBinOp "+"  "+"         6 LeftAssoc-  , makeBinOp "-"  "-"         6 LeftAssoc-  , makeBinOp "++" "append"    5 RightAssoc-  , makeBinOp "::" "cons"      5 RightAssoc-  , makeBinOp "="  "eq?"       4 LeftAssoc-  , makeBinOp "<=" "lte?"      4 LeftAssoc-  , makeBinOp ">=" "gte?"      4 LeftAssoc-  , makeBinOp "<"  "lt?"       4 LeftAssoc-  , makeBinOp ">"  "gt?"       4 LeftAssoc-  , makeBinOp "&&" "and"       3 RightAssoc-  , makeBinOp "||" "or"        2 RightAssoc+reservedExprInfix :: [Infix]+reservedExprInfix =+  [ makeInfix "^"  "**"        8 LeftAssoc+  , makeInfix "*"  "*"         7 LeftAssoc+  , makeInfix "/"  "/"         7 LeftAssoc+  , makeInfix "."  "."         7 LeftAssoc -- tensor multiplication+  , makeInfix "%"  "remainder" 7 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 "$"  "apply"     0 RightAssoc   ]   where-    makeBinOp r f p a =-      EgisonBinOp { repr = r, func = f, priority = p, assoc = a, isWedge = False }+    makeInfix r f p a =+      Infix { repr = r, func = f, priority = p, assoc = a, isWedge = False }++reservedPatternInfix :: [Infix]+reservedPatternInfix =+  [ makeInfix "::" "cons" 5 RightAssoc+  , makeInfix "++" "join" 5 RightAssoc+  , makeInfix "&"  "&"    3 RightAssoc+  , makeInfix "|"  "|"    2 RightAssoc+  ]+  where+    makeInfix r f p a =+      Infix { repr = r, func = f, priority = p, assoc = a, isWedge = False }  instance Hashable (Index ()) instance Hashable Var

@@ -1,6 +1,5 @@ {- | Module      : Language.Egison.CmdOptions-Copyright   : Satoshi Egi Licence     : MIT  This module provides command line options of Egison interpreter.

@@ -5,7 +5,6 @@  {- | Module      : Language.Egison.Core-Copyright   : Satoshi Egi Licence     : MIT  This module provides functions to evaluate various objects.@@ -62,6 +61,7 @@  import           Language.Egison.AST import           Language.Egison.CmdOptions+import           Language.Egison.Data import           Language.Egison.MathExpr import           Language.Egison.Parser      as Parser import           Language.Egison.ParserNonS  as ParserNonS@@ -93,6 +93,7 @@          else do exprs' <- if optSExpr opts then Parser.loadLibraryFile file                                             else ParserNonS.loadLibraryFile file                  collectDefs opts (exprs' ++ exprs) bindings rest+    InfixDecl{} -> collectDefs opts exprs bindings rest collectDefs _ [] bindings rest = return (bindings, reverse rest)  evalTopExpr' :: EgisonOpts -> StateT [(Var, EgisonExpr)] EgisonM Env -> EgisonTopExpr -> EgisonM (Maybe String, StateT [(Var, EgisonExpr)] EgisonM Env)@@ -106,7 +107,6 @@   case (optSExpr opts, optMathExpr opts) of     (False, Nothing) -> return (Just (show val), st)     _  -> return (Just (prettyS val), st)-   evalTopExpr' _ st (Execute expr) = do   pushFuncName "<stdin>"   io <- evalStateT st [] >>= flip evalExpr expr@@ -121,6 +121,7 @@   exprs <- if optSExpr opts then Parser.loadFile file else ParserNonS.loadFile file   (bindings, _) <- collectDefs opts exprs [] []   return (Nothing, withStateT (\defines -> bindings ++ defines) st)+evalTopExpr' _ st InfixDecl{} = return (Nothing, st)  evalExpr :: Env -> EgisonExpr -> EgisonM WHNFData evalExpr _ (CharExpr c)    = return . Value $ Char c@@ -132,7 +133,7 @@ evalExpr env (QuoteExpr expr) = do   whnf <- evalExpr env expr   case whnf of-    Value (ScalarData s) -> return . Value $ ScalarData $ Div (Plus [Term 1 [(Quote s, 1)]]) (Plus [Term 1 []])+    Value (ScalarData s) -> return . Value $ ScalarData $ SingleTerm 1 [(Quote s, 1)]     _ -> throwError =<< TypeMismatch "scalar in quote" whnf <$> getFuncNameStack  evalExpr env (QuoteSymbolExpr expr) = do@@ -180,34 +181,43 @@   return . Intermediate . IArray $ Array.listArray (1, toInteger (length exprs)) refs'  evalExpr env@(Env frame maybe_vwi) (VectorExpr exprs) = do-  whnfs <- mapM (\(expr, i) ->-    let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList [toEgison $ toInteger i]) maybe_vwi-     in evalExpr env' expr) $ zip exprs [1..(length exprs + 1)]+  let n = toInteger (length exprs)+  let indices = [1 .. (n + 1)]+  whnfs <- zipWithM evalWithIndex exprs indices   case whnfs of     Intermediate (ITensor Tensor{}):_ ->-      mapM toTensor (zipWith (curry f) whnfs [1..(length exprs + 1)]) >>= tConcat' >>= fromTensor-    _ -> fromTensor (Tensor [fromIntegral $ length whnfs] (V.fromList whnfs) [])- where-  f (Intermediate (ITensor (Tensor ns xs indices)), i) =-    Intermediate $ ITensor $ Tensor ns (V.fromList $ zipWith (curry g) (V.toList xs) $ map (\ms -> map toEgison $ toInteger i:ms) $ enumTensorIndices ns) indices-  f (x, _) = x-  g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p)), ms) =-    let fn' = maybe fn (\(VarWithIndices nameString indexList) -> symbolScalarData' "" $ prettyS $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi-     in Value $ ScalarData $ Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p-  g (x, _) = x+      mapM toTensor (zipWith f whnfs indices) >>= tConcat' >>= fromTensor+    _ -> fromTensor (Tensor [n] (V.fromList whnfs) [])+  where+    evalWithIndex :: EgisonExpr -> Integer -> EgisonM WHNFData+    evalWithIndex expr index = evalExpr env' expr+      where+        env' = case maybe_vwi of+          Nothing -> env+          Just (VarWithIndices name indices) ->+            Env frame (Just (VarWithIndices name (zipWith changeIndex indices [toEgison index])))+    f (Intermediate (ITensor (Tensor ns xs indices))) i =+      Intermediate (ITensor (Tensor ns xs' indices))+      where+        xs' = V.fromList $ zipWith g (V.toList xs) $ map (\ms -> map toEgison (i:ms)) $ enumTensorIndices ns+    f x _ = x+    g (Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn argnames args js, 1)]]) p))) ms =+      Value (ScalarData (Div (Plus [Term 1 [(FunctionData fn' argnames args js, 1)]]) p))+      where+        fn' = case maybe_vwi of+          Nothing -> fn+          Just (VarWithIndices name indices) ->+            symbolScalarData' "" $ prettyS (VarWithIndices name (zipWith changeIndex indices ms))+    g x _ = x -evalExpr env (TensorExpr nsExpr xsExpr supExpr subExpr) = do+evalExpr env (TensorExpr nsExpr xsExpr) = do   nsWhnf <- evalExpr env nsExpr   ns <- (fromCollection nsWhnf >>= fromMList >>= mapM evalRef >>= mapM fromWHNF) :: EgisonM [Integer]   xsWhnf <- evalExpr env xsExpr   xs <- fromCollection xsWhnf >>= fromMList >>= mapM evalRef-  supWhnf <- evalExpr env supExpr-  sup <- fromCollection supWhnf >>= fromMList >>= mapM evalRefDeep-  subWhnf <- evalExpr env subExpr-  sub <- fromCollection subWhnf >>= fromMList >>= mapM evalRefDeep   if product ns == toInteger (length xs)-    then fromTensor (initTensor ns xs sup sub)-    else throwError =<< InconsistentTensorSize <$> getFuncNameStack+    then fromTensor (initTensor ns xs)+    else throwError =<< InconsistentTensorShape <$> getFuncNameStack  evalExpr env (HashExpr assocs) = do   let (keyExprs, exprs) = unzip assocs@@ -234,7 +244,7 @@       _ -> throwError =<< TypeMismatch "integer or string" (Value val) <$> getFuncNameStack   makeHashKey whnf = throwError =<< TypeMismatch "integer or string" whnf <$> getFuncNameStack -evalExpr env (IndexedExpr bool expr indices) = do+evalExpr env (IndexedExpr override expr indices) = do   tensor <- case expr of               VarExpr (Var xs is) -> do                 let mObjRef = refVar env (Var xs $ is ++ map (const () <$>) indices)@@ -244,18 +254,14 @@               _ -> evalExpr env expr   js <- mapM evalIndex indices   ret <- case tensor of-      Value (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []]))) -> do+      Value (ScalarData (SingleTerm 1 [(Symbol id name [], 1)])) -> do         js2 <- mapM evalIndexToScalar indices-        return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js2, 1)]]) (Plus [Term 1 []])))-      Value (ScalarData (Div (Plus [Term 1 [(Symbol id name js', 1)]]) (Plus [Term 1 []]))) -> do+        return $ Value (ScalarData (SingleTerm 1 [(Symbol id name js2, 1)]))+      Value (ScalarData (SingleTerm 1 [(Symbol id name js', 1)])) -> do         js2 <- mapM evalIndexToScalar indices-        return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (js' ++ js2), 1)]]) (Plus [Term 1 []])))-      Value (TensorData (Tensor ns xs is)) ->-        if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)-                else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor)-      Intermediate (ITensor (Tensor ns xs is)) ->-        if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor-                else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor+        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       _ -> do         js2 <- mapM evalIndexToScalar indices         refArray tensor (map (ScalarData . extractIndex) js2)@@ -267,7 +273,7 @@   evalIndexToScalar :: Index EgisonExpr -> EgisonM (Index ScalarData)   evalIndexToScalar index = traverse ((extractScalar =<<) . evalExprDeep env) index -evalExpr env (SubrefsExpr bool expr jsExpr) = do+evalExpr env (SubrefsExpr override expr jsExpr) = do   js <- map Subscript <$> (evalExpr env jsExpr >>= collectionToList)   tensor <- case expr of               VarExpr (Var xs is) -> do@@ -277,17 +283,12 @@                   Nothing     -> evalExpr env expr               _ -> evalExpr env expr   case tensor of-    Value (ScalarData _) ->-      return tensor-    Value (TensorData (Tensor ns xs is)) ->-      if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)-              else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor)-    Intermediate (ITensor (Tensor ns xs is)) ->-      if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor-              else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor+    Value (ScalarData _)              -> return tensor+    Value (TensorData t@Tensor{})     -> Value <$> refTenworWithOverride override js t+    Intermediate (ITensor t@Tensor{}) -> refTenworWithOverride override js t     _ -> throwError =<< NotImplemented "subrefs" <$> getFuncNameStack -evalExpr env (SuprefsExpr bool expr jsExpr) = do+evalExpr env (SuprefsExpr override expr jsExpr) = do   js <- map Superscript <$> (evalExpr env jsExpr >>= collectionToList)   tensor <- case expr of               VarExpr (Var xs is) -> do@@ -297,24 +298,19 @@                   Nothing     -> evalExpr env expr               _ -> evalExpr env expr   case tensor of-    Value (ScalarData _) ->-      return tensor-    Value (TensorData (Tensor ns xs is)) ->-      if bool then Value <$> (tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor)-              else Value <$> (tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor)-    Intermediate (ITensor (Tensor ns xs is)) ->-      if bool then tref js (Tensor ns xs js) >>= toTensor >>= tContract' >>= fromTensor-              else tref (is ++ js) (Tensor ns xs (is ++ js)) >>= toTensor >>= tContract' >>= fromTensor+    Value (ScalarData _)              -> return tensor+    Value (TensorData t@Tensor{})     -> Value <$> refTenworWithOverride override js t+    Intermediate (ITensor t@Tensor{}) -> refTenworWithOverride override js t     _ -> throwError =<< NotImplemented "suprefs" <$> getFuncNameStack  evalExpr env (UserrefsExpr _ expr jsExpr) = do   val <- evalExprDeep env expr   js <- map Userscript <$> (evalExpr env jsExpr >>= collectionToList >>= mapM extractScalar)   case val of-    ScalarData (Div (Plus [Term 1 [(Symbol id name is, 1)]]) (Plus [Term 1 []])) ->-      return $ Value (ScalarData (Div (Plus [Term 1 [(Symbol id name (is ++ js), 1)]]) (Plus [Term 1 []])))-    ScalarData (Div (Plus [Term 1 [(FunctionData name argnames args is, 1)]]) (Plus [Term 1 []])) ->-      return $ Value (ScalarData (Div (Plus [Term 1 [(FunctionData name argnames args (is ++ js), 1)]]) (Plus [Term 1 []])))+    ScalarData (SingleTerm 1 [(Symbol id name is, 1)]) ->+      return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (is ++ js), 1)]))+    ScalarData (SingleTerm 1 [(FunctionData name argnames args is, 1)]) ->+      return $ Value (ScalarData (SingleTerm 1 [(FunctionData name argnames args (is ++ js), 1)]))     _ -> throwError =<< NotImplemented "user-refs" <$> getFuncNameStack  evalExpr env (LambdaExpr names expr) = do@@ -335,7 +331,7 @@  evalExpr env@(Env _ (Just name)) (FunctionExpr args) = do   args' <- mapM (evalExprDeep env) args >>= mapM extractScalar-  return . Value $ ScalarData (Div (Plus [Term 1 [(FunctionData (symbolScalarData' "" (prettyS name)) (map (symbolScalarData' "" . prettyS) args) args' [], 1)]]) (Plus [Term 1 []]))+  return . Value $ ScalarData (SingleTerm 1 [(FunctionData (symbolScalarData' "" (prettyS name)) (map (symbolScalarData' "" . prettyS) args) args' [], 1)])  evalExpr env (IfExpr test expr expr') = do   test <- evalExpr env test >>= fromWHNF@@ -402,10 +398,10 @@     _ -> return whnf  where   isTmpSymbol :: String -> Index EgisonValue -> Bool-  isTmpSymbol symId (Subscript    (ScalarData (Div (Plus [Term 1 [(Symbol id _ _, _)]]) (Plus [Term 1 []])))) = symId == id-  isTmpSymbol symId (Superscript  (ScalarData (Div (Plus [Term 1 [(Symbol id _ _, _)]]) (Plus [Term 1 []])))) = symId == id-  isTmpSymbol symId (SupSubscript (ScalarData (Div (Plus [Term 1 [(Symbol id _ _, _)]]) (Plus [Term 1 []])))) = symId == id-  isTmpSymbol symId (Userscript   (ScalarData (Div (Plus [Term 1 [(Symbol id _ _, _)]]) (Plus [Term 1 []])))) = symId == id+  isTmpSymbol symId (Subscript    (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id+  isTmpSymbol symId (Superscript  (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id+  isTmpSymbol symId (SupSubscript (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id+  isTmpSymbol symId (Userscript   (ScalarData (SingleTerm 1 [(Symbol id _ _, _)]))) = symId == id   removeTmpScripts :: HasTensor a => String -> Tensor a -> EgisonM (Tensor a)   removeTmpScripts symId (Tensor s xs is) = do     let (ds, js) = partition (isTmpSymbol symId) is@@ -489,7 +485,7 @@ evalExpr env (ApplyExpr func arg) = do   func <- evalExpr env func >>= appendDFscripts 0   case func of---    Value (ScalarData (Div (Plus [Term 1 [(Symbol "" name@(c:_) [], 1)]]) (Plus [Term 1 []]))) | isUpper c ->+--    Value (ScalarData (SingleTerm 1 [(Symbol "" name@(c:_) [], 1)])) | isUpper c ->     Value (InductiveData name []) ->       case arg of         TupleExpr exprs ->@@ -572,16 +568,15 @@ evalExpr env (ArrayBoundsExpr expr) =   evalExpr env expr >>= arrayBounds --- TODO(momohatt): Following numpy's convention, rename 'size' into 'shape'.-evalExpr env (GenerateTensorExpr fnExpr sizeExpr) = do-  size <- evalExpr env sizeExpr >>= collectionToList-  ns   <- mapM fromEgison size :: EgisonM [Integer]-  xs   <- mapM (indexToWHNF env . map toEgison) (enumTensorIndices ns)+evalExpr env (GenerateTensorExpr fnExpr shapeExpr) = do+  shape <- evalExpr env shapeExpr >>= collectionToList+  ns    <- mapM fromEgison shape :: EgisonM Shape+  xs    <- mapM (indexToWHNF env . map toEgison) (enumTensorIndices ns)   fromTensor (Tensor ns (V.fromList xs) [])  where   indexToWHNF :: Env -> [EgisonValue] {- index -} -> EgisonM WHNFData   indexToWHNF (Env frame maybe_vwi) ms = do-    let env' = maybe env (\(VarWithIndices nameString indexList) -> Env frame $ Just $ VarWithIndices nameString $ changeIndexList indexList ms) maybe_vwi+    let env' = maybe env (\(VarWithIndices name indices) -> Env frame $ Just $ VarWithIndices name $ zipWith changeIndex indices ms) maybe_vwi     fn <- evalExpr env' fnExpr     applyFunc env fn $ Value $ makeTuple ms @@ -786,12 +781,12 @@   case arg of      Value World -> m      _           -> throwError =<< TypeMismatch "world" arg <$> getFuncNameStack-applyFunc _ (Value (ScalarData fn@(Div (Plus [Term 1 [(Symbol{}, 1)]]) (Plus [Term 1 []])))) arg = do+applyFunc _ (Value (ScalarData fn@(SingleTerm 1 [(Symbol{}, 1)]))) arg = do   args <- tupleToList arg   mExprs <- mapM (\arg -> case arg of                             ScalarData _ -> extractScalar arg                             _ -> throwError =<< EgisonBug "to use undefined functions, you have to use ScalarData args" <$> getFuncNameStack) args-  return (Value (ScalarData (Div (Plus [Term 1 [(Apply fn mExprs, 1)]]) (Plus [Term 1 []]))))+  return (Value (ScalarData (SingleTerm 1 [(Apply fn mExprs, 1)]))) applyFunc _ whnf _ = throwError =<< TypeMismatch "function" whnf <$> getFuncNameStack  refArray :: WHNFData -> [EgisonValue] -> EgisonM WHNFData@@ -803,7 +798,7 @@               then refArray (Value (array Array.! i)) indices               else return  $ Value Undefined     else case index of-           ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []])) -> do+           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@@ -817,7 +812,7 @@                    evalRef ref >>= flip refArray indices               else return  $ Value Undefined     else case index of-           ScalarData (Div (Plus [Term 1 [(Symbol _ _ [], 1)]]) (Plus [Term 1 []])) -> do+           ScalarData (SingleTerm 1 [(Symbol _ _ [], 1)]) -> do              let (_,size) = Array.bounds array              let refs = Array.elems array              arrs <- mapM evalRef refs@@ -952,6 +947,11 @@ processMStatesAllDFS (MCons (MState _ _ [] bindings []) ms) = MCons bindings . processMStatesAllDFS <$> ms processMStatesAllDFS (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFS +processMStatesAllDFSForall :: MList EgisonM MatchingState -> EgisonM (MList EgisonM MatchingState)+processMStatesAllDFSForall MNil = return MNil+processMStatesAllDFSForall (MCons mstate@(MState _ _ (ForallPatContext _ _ : _) _ []) ms) = MCons mstate . processMStatesAllDFSForall <$> ms+processMStatesAllDFSForall (MCons mstate ms) = processMState mstate >>= (`mappend` ms) >>= processMStatesAllDFSForall+ processMStatesAll :: [MList EgisonM MatchingState] -> EgisonM (MList EgisonM Match) processMStatesAll [] = return MNil processMStatesAll streams = do@@ -976,42 +976,62 @@ gatherBindings mstate@MState{ seqPatCtx = [], mTrees = [] } = return (mStateBindings mstate) gatherBindings _ = Nothing -topMAtom :: MatchingState -> Maybe MatchingTree-topMAtom MState{ mTrees = mAtom@MAtom{}:_ }  = Just mAtom-topMAtom MState{ mTrees = MNode _ mstate:_ } = topMAtom mstate-topMAtom _ = Nothing- processMState :: MatchingState -> EgisonM (MList EgisonM MatchingState) processMState state =-  case topMAtom state of-    Just (MAtom (NotPat _) _ _) -> do-      let (state1, state2) = splitMState state-      result <- processMStatesAll [msingleton state1]-      case result of-        MNil -> return $ msingleton state2-        _    -> return MNil-    _ -> processMState' state+  if nullMState state+    then processMState' state+    else case splitMState state of+           (1, state1, state2) -> do+             result <- processMStatesAllDFS (msingleton state1)+             case result of+               MNil -> return $ msingleton state2+               _    -> return MNil+           (0, MState e l s b [MAtom (ForallPat p1 p2) m t], MState{ mTrees = trees }) -> do+             states <- processMStatesAllDFSForall (msingleton (MState e l (ForallPatContext [] []:s) b [MAtom p1 m t]))+             statess' <- mmap (\(MState e' l' (ForallPatContext ms ts:s') b' []) -> do+                                   let mat' = makeTuple ms+                                   tgt' <- makeITuple ts+                                   processMStatesAllDFSForall (msingleton (MState e' l' (ForallPatContext [] []:s') b' [MAtom p2 tgt' mat']))) states+             b <- mAny (\s -> case s of+                                MNil -> return True+                                _ -> return False) statess'+             if b+               then return MNil+--               else return MNil+               else do nstatess <- mmap (\states' -> mmap (\(MState e' l' (ForallPatContext [] []:s') b' []) -> return $ MState e' l' s' b' trees) states') statess'+                       mconcat nstatess+           _ -> processMState' state  where-  splitMState :: MatchingState -> (MatchingState, MatchingState)+  nullMState :: MatchingState -> Bool+  nullMState MState{ mTrees = [] } = True+  nullMState MState{ mTrees = MNode _ state : _ } = nullMState state+  nullMState _ = False+  splitMState :: MatchingState -> (Integer, MatchingState, MatchingState)   splitMState mstate@MState{ mTrees = MAtom (NotPat pattern) target matcher : trees } =-    (mstate { mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees })+    (1, mstate { mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees })+  splitMState mstate@MState{ mTrees = MAtom pattern target matcher : trees } =+    (0, mstate { mTrees = [MAtom pattern target matcher] }, mstate { mTrees = trees })   splitMState mstate@MState{ mTrees = MNode penv state' : trees } =-    (mstate { mTrees = [MNode penv state1] }, mstate { mTrees = MNode penv state2 : trees })-      where (state1, state2) = splitMState state'+    (f, mstate { mTrees = [MNode penv state1] }, mstate { mTrees = MNode penv state2 : trees })+      where (f, state1, state2) = splitMState state'  processMState' :: MatchingState -> EgisonM (MList EgisonM MatchingState)-processMState' MState{ seqPatCtx = [], mTrees = [] } = throwError =<< EgisonBug "should not reach here (empty matching-state)" <$> getFuncNameStack+--processMState' MState{ seqPatCtx = [], mTrees = [] } = throwError =<< EgisonBug "should not reach here (empty matching-state)" <$> getFuncNameStack+processMState' mstate@MState{ seqPatCtx = [], mTrees = [] } = return . msingleton $ mstate -- for forall pattern used in matchAll (not matchAllDFS) --- Sequential patterns+-- Sequential patterns and forall pattern processMState' mstate@MState{ seqPatCtx = SeqPatContext stack SeqNilPat [] []:seqs, mTrees = [] } =   return . msingleton $ mstate { seqPatCtx = seqs, mTrees = stack } processMState' mstate@MState{ seqPatCtx = SeqPatContext stack seqPat mats tgts:seqs, mTrees = [] } = do   let mat' = makeTuple mats   tgt' <- makeITuple tgts   return . msingleton $ mstate { seqPatCtx = seqs, mTrees = MAtom seqPat tgt' mat' : stack }+processMState' mstate@MState{ seqPatCtx = ForallPatContext _ _:_, mTrees = [] } =+  return . msingleton $ mstate  -- Matching Nodes-processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwError =<< EgisonBug "should not reach here (empty matching-node)" <$> getFuncNameStack+--processMState' MState{ mTrees = MNode _ MState{ mStateBindings = [], mTrees = [] }:_ } = throwError =<< EgisonBug "should not reach here (empty matching-node)" <$> getFuncNameStack+processMState' mstate@MState{ mTrees = MNode _ MState{ seqPatCtx = [], mTrees = [] }:trees } = return . msingleton $ mstate { mTrees = trees }  processMState' ms1@MState{ mTrees = MNode penv ms2@MState{ mTrees = MAtom (VarPat name) target matcher:trees' }:trees } =   case lookup name penv of@@ -1034,14 +1054,19 @@  processMState' mstate@MState{ mTrees = MNode penv state:trees } =   processMState' state >>= mmap (\state' -> case state' of-                                              MState { mTrees = [] } -> return $ mstate { mTrees = trees }+--egi                                              MState { mTrees = [] } -> return $ mstate { mTrees = trees }                                               _ -> return $ mstate { mTrees = MNode penv state':trees })  -- Matching Atoms processMState' mstate@(MState env loops seqs bindings (MAtom pattern target matcher:trees)) =   let env' = extendEnvForNonLinearPatterns env bindings loops in   case pattern of-    NotPat _ -> throwError =<< EgisonBug "should not reach here (not pattern)" <$> getFuncNameStack+    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))++    NotPat _ -> throwError =<< EgisonBug "should not reach here (not-pattern)" <$> getFuncNameStack     VarPat _ -> throwError $ Default $ "cannot use variable except in pattern function:" ++ prettyS pattern      LetPat bindings' pattern' -> do@@ -1114,6 +1139,7 @@       case seqs of         [] -> throwError $ Default "cannot use # out of seq patterns"         (SeqPatContext stack pat mats tgts:seqs) -> return . msingleton $ MState env loops (SeqPatContext stack pat (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees+        (ForallPatContext mats tgts:seqs) -> return . msingleton $ MState env loops (ForallPatContext (mats ++ [matcher]) (tgts ++ [target]):seqs) bindings trees     AndPat patterns ->       let trees' = map (\pat -> MAtom pat target matcher) patterns ++ trees        in return . msingleton $ mstate { mTrees = trees' }@@ -1428,3 +1454,10 @@ makeITuple []  = return $ Intermediate (ITuple []) makeITuple [x] = return x makeITuple xs  = Intermediate . ITuple <$> mapM newEvaluatedObjectRef xs++-- 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) =+  tref js' (Tensor ns xs js') >>= toTensor >>= tContract' >>= fromTensor+    where+      js' = if override then js else is ++ js

@@ -0,0 +1,846 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE UndecidableInstances       #-}++{- |+Module      : Language.Egison.Data+Licence     : MIT++This module contains definitions for Egison internal data.+-}++module Language.Egison.Data+    (+    -- * Egison values+      EgisonValue (..)+    , Matcher+    , PrimitiveFunc+    , EgisonHashKey (..)+    , EgisonData (..)+    , Tensor (..)+    , Shape+    , HasTensor (..)+    -- * Scalar+    , symbolScalarData+    , symbolScalarData'+    , getSymId+    , getSymName+    , mathExprToEgison+    , egisonToScalarData+    , extractScalar+    , extractScalar'+    -- * Internal data+    , Object (..)+    , ObjectRef+    , WHNFData (..)+    , Intermediate (..)+    , Inner (..)+    , EgisonWHNF (..)+    -- * Environment+    , Env (..)+    , Binding+    , nullEnv+    , extendEnv+    , refVar+    -- * Pattern matching+    , Match+    , MatchingTree (..)+    , MatchingState (..)+    , PatternBinding+    , LoopPatContext (..)+    , SeqPatContext (..)+    -- * Errors+    , EgisonError (..)+    , liftError+    -- * Monads+    , EgisonM (..)+    , 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.Trans.Maybe+import           Control.Monad.Writer      (WriterT)++import qualified Data.Array                as Array+import           Data.Foldable             (foldr, 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++import           Data.List                 (intercalate)+import           Data.Text                 (Text)++import           Data.Ratio+import           System.IO++import           System.IO.Unsafe          (unsafePerformIO)++import           Language.Egison.AST+import           Language.Egison.MathExpr++--+-- Values+--++data EgisonValue =+    World+  | Char Char+  | String Text+  | Bool Bool+  | ScalarData ScalarData+  | TensorData (Tensor EgisonValue)+  | Float Double+  | 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)+  | UserMatcher Env [PatternDef]+  | Func (Maybe Var) Env [String] EgisonExpr+  | PartialFunc Env Integer EgisonExpr+  | CFunc (Maybe Var) Env String EgisonExpr+  | MemoizedFunc (Maybe Var) ObjectRef (IORef (HashMap [Integer] ObjectRef)) Env [String] EgisonExpr+  | Proc (Maybe String) Env [String] EgisonExpr+  | PatternFunc Env [String] EgisonPattern+  | PrimitiveFunc String PrimitiveFunc+  | IOFunc (EgisonM WHNFData)+  | Port Handle+  | Something+  | Undefined++type Matcher = EgisonValue++type PrimitiveFunc = WHNFData -> EgisonM WHNFData++data EgisonHashKey =+    IntKey Integer+  | CharKey Char+  | StrKey Text++--+-- Scalar and Tensor Types+--++data Tensor a =+    Tensor Shape (V.Vector a) [Index EgisonValue]+  | Scalar a+ deriving (Show)++type Shape = [Integer]++class HasTensor a where+  tensorElems :: a -> V.Vector a+  tensorShape :: a -> Shape+  tensorIndices :: a -> [Index EgisonValue]+  fromTensor :: Tensor a -> EgisonM a+  toTensor :: a -> EgisonM (Tensor a)+  undef :: a++instance HasTensor EgisonValue where+  tensorElems (TensorData (Tensor _ xs _)) = xs+  tensorShape (TensorData (Tensor ns _ _)) = ns+  tensorIndices (TensorData (Tensor _ _ js)) = js+  fromTensor t@Tensor{} = return $ TensorData t+  fromTensor (Scalar x) = return x+  toTensor (TensorData t) = return t+  toTensor x              = return $ Scalar x+  undef = Undefined++instance HasTensor WHNFData where+  tensorElems (Intermediate (ITensor (Tensor _ xs _))) = xs+  tensorShape (Intermediate (ITensor (Tensor ns _ _))) = ns+  tensorIndices (Intermediate (ITensor (Tensor _ _ js))) = js+  fromTensor t@Tensor{} = return $ Intermediate $ ITensor t+  fromTensor (Scalar x) = return x+  toTensor (Intermediate (ITensor t)) = return t+  toTensor x                          = return $ Scalar x+  undef = Value Undefined++--+-- Scalars+--++symbolScalarData :: String -> String -> EgisonValue+symbolScalarData id name = ScalarData (SingleTerm 1 [(Symbol id name [], 1)])++symbolScalarData' :: String -> String -> ScalarData+symbolScalarData' id name = SingleTerm 1 [(Symbol id name [], 1)]++getSymId :: EgisonValue -> String+getSymId (ScalarData (SingleTerm 1 [(Symbol id _ [], 1)])) = id++getSymName :: EgisonValue -> String+getSymName (ScalarData (SingleTerm 1 [(Symbol _ name [], 1)])) = name++mathExprToEgison :: ScalarData -> EgisonValue+mathExprToEgison (Div p1 p2) = InductiveData "Div" [polyExprToEgison p1, polyExprToEgison p2]++polyExprToEgison :: PolyExpr -> EgisonValue+polyExprToEgison (Plus ts) = InductiveData "Plus" [Collection (Sq.fromList (map termExprToEgison ts))]++termExprToEgison :: TermExpr -> EgisonValue+termExprToEgison (Term a xs) = InductiveData "Term" [toEgison a, Collection (Sq.fromList (map symbolExprToEgison xs))]++symbolExprToEgison :: (SymbolExpr, Integer) -> EgisonValue+symbolExprToEgison (Symbol id x js, n) = Tuple [InductiveData "Symbol" [symbolScalarData id x, f js], toEgison n]+ where+  f js = Collection (Sq.fromList (map scalarIndexToEgison js))+symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [ScalarData fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n]+symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n]+symbolExprToEgison (FunctionData name argnames args js, n) =+  Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData argnames)), Collection (Sq.fromList (map ScalarData args)), f js], toEgison n]+ where+  f js = Collection (Sq.fromList (map scalarIndexToEgison js))++scalarIndexToEgison :: Index ScalarData -> EgisonValue+scalarIndexToEgison (Superscript k) = InductiveData "Sup"  [ScalarData k]+scalarIndexToEgison (Subscript k)   = InductiveData "Sub"  [ScalarData k]+scalarIndexToEgison (Userscript k)  = InductiveData "User" [ScalarData k]++egisonToScalarData :: EgisonValue -> EgisonM ScalarData+egisonToScalarData (InductiveData "Div" [p1, p2]) = Div <$> egisonToPolyExpr p1 <*> egisonToPolyExpr p2+egisonToScalarData p1@(InductiveData "Plus" _) = Div <$> egisonToPolyExpr p1 <*> return (Plus [Term 1 []])+egisonToScalarData t1@(InductiveData "Term" _) = do+  t1' <- egisonToTermExpr t1+  return $ Div (Plus [t1']) (Plus [Term 1 []])+egisonToScalarData s1@(InductiveData "Symbol" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 ::Integer)])+  return $ SingleTerm 1 [s1']+egisonToScalarData s1@(InductiveData "Apply" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])+  return $ SingleTerm 1 [s1']+egisonToScalarData s1@(InductiveData "Quote" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])+  return $ SingleTerm 1 [s1']+egisonToScalarData s1@(InductiveData "Function" _) = do+  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])+  return $ SingleTerm 1 [s1']+egisonToScalarData val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack++egisonToPolyExpr :: EgisonValue -> EgisonM PolyExpr+egisonToPolyExpr (InductiveData "Plus" [Collection ts]) = Plus <$> mapM egisonToTermExpr (toList ts)+egisonToPolyExpr val = throwError =<< TypeMismatch "math poly expression" (Value val) <$> getFuncNameStack++egisonToTermExpr :: EgisonValue -> EgisonM TermExpr+egisonToTermExpr (InductiveData "Term" [n, Collection ts]) = Term <$> fromEgison n <*> mapM egisonToSymbolExpr (toList ts)+egisonToTermExpr val = throwError =<< TypeMismatch "math term expression" (Value val) <$> getFuncNameStack++egisonToSymbolExpr :: EgisonValue -> EgisonM (SymbolExpr, Integer)+egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, Collection seq], n]) = do+  let js = toList seq+  js' <- mapM egisonToScalarIndex js+  n' <- fromEgison n+  case x of+    (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []]))) ->+      return (Symbol id name js', n')+egisonToSymbolExpr (Tuple [InductiveData "Apply" [fn, Collection mExprs], n]) = do+  fn' <- extractScalar fn+  mExprs' <- mapM egisonToScalarData (toList mExprs)+  n' <- fromEgison n+  return (Apply fn' mExprs', n')+egisonToSymbolExpr (Tuple [InductiveData "Quote" [mExpr], n]) = do+  mExpr' <- egisonToScalarData mExpr+  n' <- fromEgison n+  return (Quote mExpr', n')+egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection argnames, Collection args, Collection seq], n]) = do+  name' <- extractScalar name+  argnames' <- mapM extractScalar (toList argnames)+  args' <- mapM extractScalar (toList args)+  let js = toList seq+  js' <- mapM egisonToScalarIndex js+  n' <- fromEgison n+  return (FunctionData name' argnames' args' js', n')+egisonToSymbolExpr val = throwError =<< TypeMismatch "math symbol expression" (Value val) <$> getFuncNameStack++egisonToScalarIndex :: EgisonValue -> EgisonM (Index ScalarData)+egisonToScalarIndex j = case j of+  InductiveData "Sup"  [ScalarData k] -> return (Superscript k)+  InductiveData "Sub"  [ScalarData k] -> return (Subscript k)+  InductiveData "User" [ScalarData k] -> return (Userscript k)+  _ -> throwError =<< TypeMismatch "math symbol expression" (Value j) <$> getFuncNameStack++--+-- ExtractScalar+--++extractScalar :: EgisonValue -> EgisonM ScalarData+extractScalar (ScalarData mExpr) = return mExpr+extractScalar val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack++extractScalar' :: WHNFData -> EgisonM ScalarData+extractScalar' (Value (ScalarData x)) = return x+extractScalar' val = throwError =<< TypeMismatch "integer or string" val <$> getFuncNameStack++--+--+--++-- New-syntax version of EgisonValue pretty printer.+-- TODO(momohatt): Don't make it a show instance of EgisonValue.+instance Show EgisonValue where+  show (Char c) = '\'' : c : "'"+  show (String str) = show str+  show (Bool True) = "True"+  show (Bool False) = "False"+  show (ScalarData mExpr) = show mExpr+  show (TensorData (Tensor [_] xs js)) = "[| " ++ intercalate ", " (map show (V.toList xs)) ++ " |]" ++ concatMap show js+  show (TensorData (Tensor [0, 0] _ js)) = "[| [|  |] |]" ++ concatMap show js+  show (TensorData (Tensor [_, j] xs js)) = "[| " ++ intercalate ", " (f (fromIntegral j) (V.toList xs)) ++ " |]" ++ concatMap show js+    where+      f _ [] = []+      f j xs = ["[| " ++ intercalate ", " (map show (take j xs)) ++ " |]"] ++ f j (drop j xs)+  show (TensorData (Tensor ns xs js)) = "(tensor [" ++ intercalate ", " (map show ns) ++ "] [" ++ intercalate ", " (map show (V.toList xs)) ++ "] )" ++ concatMap show js+  show (Float x) = show x+  show (InductiveData name vals) = name ++ concatMap ((' ':) . show') vals+    where+      show' x | isAtomic x = show x+              | 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) ++ "|}"+  show UserMatcher{} = "#<user-matcher>"+  show (Func Nothing _ args _) = "(lambda [" ++ intercalate ", " (map show args) ++ "] ...)"+  show (Func (Just name) _ _ _) = show name+  show (PartialFunc _ n expr) = show n ++ "#" ++ show expr+  show (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)"+  show (CFunc (Just name) _ _ _) = show name+  show (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ intercalate ", " names ++ "] ...)"+  show (MemoizedFunc (Just name) _ _ _ _ _) = show name+  show (Proc Nothing _ names _) = "(procedure [" ++ intercalate ", " names ++ "] ...)"+  show (Proc (Just name) _ _ _) = name+  show PatternFunc{} = "#<pattern-function>"+  show (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"+  show (IOFunc _) = "#<io-function>"+  show (Port _) = "#<port>"+  show Something = "something"+  show Undefined = "undefined"+  show World = "#<world>"++-- False if we have to put parenthesis around it to make it an atomic expression.+isAtomic :: EgisonValue -> Bool+isAtomic (InductiveData _ []) = True+isAtomic (InductiveData _ _)  = False+isAtomic (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = True+isAtomic (ScalarData _) = False+isAtomic _ = True++instance Eq EgisonValue where+ (Char c) == (Char c') = c == c'+ (String str) == (String str') = str == str'+ (Bool b) == (Bool b') = b == b'+ (ScalarData x) == (ScalarData y) = x == y+ (TensorData (Tensor js xs _)) == (TensorData (Tensor js' xs' _)) = (js == js') && (xs == xs')+ (Float x) == (Float x') = x == x'+ (InductiveData name vals) == (InductiveData name' vals') = (name == name') && (vals == vals')+ (Tuple vals) == (Tuple vals') = vals == vals'+ (Collection vals) == (Collection vals') = vals == vals'+ (Array vals) == (Array vals') = vals == vals'+ (IntHash vals) == (IntHash vals') = vals == vals'+ (CharHash vals) == (CharHash vals') = vals == vals'+ (StrHash vals) == (StrHash vals') = vals == vals'+ (PrimitiveFunc name1 _) == (PrimitiveFunc name2 _) = name1 == name2+ -- Temporary: searching a better solution+ (Func Nothing _ xs1 expr1) == (Func Nothing _ xs2 expr2) = (xs1 == xs2) && (expr1 == expr2)+ (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _) = name1 == name2+ (CFunc Nothing _ x1 expr1) == (CFunc Nothing _ x2 expr2) = (x1 == x2) && (expr1 == expr2)+ (CFunc (Just name1) _ _ _) == (CFunc (Just name2) _ _ _) = name1 == name2+ _ == _ = False++--+-- Egison data and Haskell data+--+class EgisonData a where+  toEgison :: a -> EgisonValue+  fromEgison :: EgisonValue -> EgisonM a++instance EgisonData Char where+  toEgison = Char+  fromEgison (Char c) = return c+  fromEgison val      = throwError =<< TypeMismatch "char" (Value val) <$> getFuncNameStack++instance EgisonData Text where+  toEgison = String+  fromEgison (String str) = return str+  fromEgison val          = throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack++instance EgisonData Bool where+  toEgison = Bool+  fromEgison (Bool b) = return b+  fromEgison val      = throwError =<< TypeMismatch "bool" (Value val) <$> getFuncNameStack++instance EgisonData Integer where+  toEgison 0 = ScalarData $ mathNormalize' (Div (Plus []) (Plus [Term 1 []]))+  toEgison i = ScalarData $ mathNormalize' (SingleTerm i [])+  fromEgison (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = return 0+  fromEgison (ScalarData (SingleTerm x [])) = return x+  fromEgison val = throwError =<< TypeMismatch "integer" (Value val) <$> getFuncNameStack++instance EgisonData Rational where+  toEgison r = ScalarData $ mathNormalize' (Div (Plus [Term (numerator r) []]) (Plus [Term (denominator r) []]))+  fromEgison (ScalarData (Div (Plus []) _)) = return 0+  fromEgison (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return (x % y)+  fromEgison val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack++instance EgisonData Double where+  toEgison f = Float f+  fromEgison (Float f) = return f+  fromEgison val       = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack++instance EgisonData Handle where+  toEgison = Port+  fromEgison (Port h) = return h+  fromEgison val      = throwError =<< TypeMismatch "port" (Value val) <$> getFuncNameStack++instance EgisonData a => EgisonData [a] where+  toEgison xs = Collection $ Sq.fromList (map toEgison xs)+  fromEgison (Collection seq) = mapM fromEgison (toList seq)+  fromEgison val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack++instance EgisonData () where+  toEgison () = Tuple []+  fromEgison (Tuple []) = return ()+  fromEgison val = throwError =<< TypeMismatch "zero element tuple" (Value val) <$> getFuncNameStack++instance (EgisonData a, EgisonData b) => EgisonData (a, b) where+  toEgison (x, y) = Tuple [toEgison x, toEgison y]+  fromEgison (Tuple [x, y]) = liftM2 (,) (fromEgison x) (fromEgison y)+  fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack++instance (EgisonData a, EgisonData b, EgisonData c) => EgisonData (a, b, c) where+  toEgison (x, y, z) = Tuple [toEgison x, toEgison y, toEgison z]+  fromEgison (Tuple [x, y, z]) = do+    x' <- fromEgison x+    y' <- fromEgison y+    z' <- fromEgison z+    return (x', y', z')+  fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack++instance (EgisonData a, EgisonData b, EgisonData c, EgisonData d) => EgisonData (a, b, c, d) where+  toEgison (x, y, z, w) = Tuple [toEgison x, toEgison y, toEgison z, toEgison w]+  fromEgison (Tuple [x, y, z, w]) = do+    x' <- fromEgison x+    y' <- fromEgison y+    z' <- fromEgison z+    w' <- fromEgison w+    return (x', y', z', w')+  fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack++--+-- Internal Data+--++-- |For memoization+type ObjectRef = IORef Object++data Object =+    Thunk (EgisonM WHNFData)+  | WHNF WHNFData++data WHNFData =+    Intermediate Intermediate+  | Value EgisonValue++data Intermediate =+    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)+  | ITensor (Tensor WHNFData)++data Inner =+    IElement ObjectRef+  | ISubCollection ObjectRef++instance Show WHNFData where+  show (Value val) = show val+  show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>"+  show (Intermediate (ITuple _)) = "[...]"+  show (Intermediate (ICollection _)) = "{...}"+  show (Intermediate (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) ++ "|]"++instance Show Object where+  show (Thunk _)   = "#<thunk>"+  show (WHNF whnf) = show whnf++instance Show ObjectRef where+  show _ = "#<ref>"++--+-- Extract data from WHNF+--+class EgisonData a => EgisonWHNF a where+  toWHNF :: a -> WHNFData+  fromWHNF :: WHNFData -> EgisonM a+  toWHNF = Value . toEgison++instance EgisonWHNF Char where+  fromWHNF (Value (Char c)) = return c+  fromWHNF whnf             = throwError =<< TypeMismatch "char" whnf <$> getFuncNameStack++instance EgisonWHNF Text where+  fromWHNF (Value (String str)) = return str+  fromWHNF whnf                 = throwError =<< TypeMismatch "string" whnf <$> getFuncNameStack++instance EgisonWHNF Bool where+  fromWHNF (Value (Bool b)) = return b+  fromWHNF whnf             = throwError =<< TypeMismatch "bool" whnf <$> getFuncNameStack++instance EgisonWHNF Integer where+  fromWHNF (Value (ScalarData (Div (Plus []) (Plus [Term 1 []])))) = return 0+  fromWHNF (Value (ScalarData (SingleTerm x []))) = return x+  fromWHNF whnf = throwError =<< TypeMismatch "integer" whnf <$> getFuncNameStack++instance EgisonWHNF Double where+  fromWHNF (Value (Float f)) = return f+  fromWHNF whnf              = throwError =<< TypeMismatch "float" whnf <$> getFuncNameStack++instance EgisonWHNF Handle where+  fromWHNF (Value (Port h)) = return h+  fromWHNF whnf             = throwError =<< TypeMismatch "port" whnf <$> getFuncNameStack++--+-- Environment+--++data Env = Env [HashMap Var ObjectRef] (Maybe VarWithIndices)+ deriving (Show)++type Binding = (Var, ObjectRef)++instance Show (Index EgisonValue) where+  show (Superscript i) = case i of+    ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "~[" ++ show i ++ "]"+    _ -> "~" ++ show i+  show (Subscript i) = case i of+    ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]"+    _ -> "_" ++ show i+  show (SupSubscript i) = "~_" ++ show i+  show (DFscript i j) = "_d" ++ show i ++ show j+  show (Userscript i) = case i of+    ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]"+    _ -> "|" ++ show i++nullEnv :: Env+nullEnv = Env [] Nothing++extendEnv :: Env -> [Binding] -> Env+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++--+-- Pattern Match+--++type Match = [Binding]++data MatchingState+  = MState { mStateEnv      :: Env+           , loopPatCtx     :: [LoopPatContext]+           , seqPatCtx      :: [SeqPatContext]+           , mStateBindings :: [Binding]+           , mTrees         :: [MatchingTree]+           }++instance Show MatchingState where+  show ms = "(MState " ++ unwords ["_", "_", "_", show (mStateBindings ms), show (mTrees ms)] ++ ")"++data MatchingTree =+    MAtom EgisonPattern WHNFData Matcher+  | MNode [PatternBinding] MatchingState+ deriving (Show)++type PatternBinding = (String, EgisonPattern)++data LoopPatContext = LoopPatContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern+ deriving (Show)++data SeqPatContext =+    SeqPatContext [MatchingTree] EgisonPattern [Matcher] [WHNFData]+  | ForallPatContext [Matcher] [WHNFData]+ deriving (Show)++--+-- Errors+--++type CallStack = [String]++data EgisonError =+    UnboundVariable String CallStack+  | TypeMismatch String WHNFData CallStack+  | ArgumentsNumWithNames [String] Int Int CallStack+  | ArgumentsNumPrimitive Int Int CallStack+  | TupleLength Int Int CallStack+  | InconsistentTensorShape CallStack+  | InconsistentTensorIndex CallStack+  | TensorIndexOutOfBounds Integer Integer CallStack+  | NotImplemented String CallStack+  | Assertion String CallStack+  | Parser String+  | EgisonBug String CallStack+  | MatchFailure String CallStack+  | Default String+  deriving Typeable++instance Show EgisonError where+  show (UnboundVariable var stack) =+    "Unbound variable: " ++ show var ++ showTrace stack+  show (TypeMismatch expected found stack) =+    "Expected " ++  expected ++ ", but found: " ++ show found ++ showTrace stack+  show (ArgumentsNumWithNames names expected got stack) =+    "Wrong number of arguments: " ++ show names ++ ": expected " ++ show expected ++ ", but got " ++  show got ++ showTrace stack+  show (ArgumentsNumPrimitive expected got stack) =+    "Wrong number of arguments for a primitive function: expected " ++ show expected ++ ", but got " ++  show got ++ showTrace stack+  show (TupleLength expected got stack) =+    "Inconsistent tuple lengths: expected " ++ show expected ++ ", but got " ++  show got ++ showTrace stack+  show (InconsistentTensorShape stack) = "Inconsistent tensor shape" ++ showTrace stack+  show (InconsistentTensorIndex stack) = "Inconsistent tensor index" ++ showTrace stack+  show (TensorIndexOutOfBounds m n stack) = "Tensor index out of bounds: " ++ show m ++ ", " ++ show n ++ showTrace stack+  show (NotImplemented message stack) = "Not implemented: " ++ message ++ showTrace stack+  show (Assertion message stack) = "Assertion failed: " ++ message ++ showTrace stack+  show (Parser err) = "Parse error at: " ++ err+  show (EgisonBug message stack) = "Egison Error: " ++ message ++ showTrace stack+  show (MatchFailure currentFunc stack) = "Failed pattern match in: " ++ currentFunc ++ showTrace stack+  show (Default message) = "Error: " ++ message++showTrace :: CallStack -> String+showTrace stack = "\n  stack trace: " ++ intercalate ", " stack++instance Exception EgisonError++liftError :: (MonadError e m) => Either e a -> m a+liftError = either throwError return++--+-- Monads+--++newtype EgisonM a = EgisonM {+    unEgisonM :: ExceptT EgisonError (FreshT IO) a+  } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh)++instance MonadFail EgisonM where+    fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack++runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a)+runEgisonM = runExceptT . unEgisonM++liftEgisonM :: Fresh (Either EgisonError a) -> EgisonM a+liftEgisonM m = EgisonM $ ExceptT $ FreshT $ do+  s <- get+  (a, s') <- return $ runFresh s m+  put s'+  return $ either throwError return a++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'

@@ -4,7 +4,6 @@  {- | Module      : Language.Egison.Desugar-Copyright   : Satoshi Egi Licence     : MIT  This module provide desugar functions.@@ -23,7 +22,7 @@ import qualified Data.Set              as S  import           Language.Egison.AST-import           Language.Egison.Types+import           Language.Egison.Data  desugarTopExpr :: EgisonTopExpr -> EgisonM EgisonTopExpr desugarTopExpr (Define name expr)   = Define name <$> desugar expr@@ -121,7 +120,7 @@  desugar (ArrayRefExpr expr nums) =   case nums of-    (TupleExpr nums') -> desugar $ IndexedExpr True expr (map Subscript nums')+    TupleExpr nums' -> desugar $ IndexedExpr True expr (map Subscript nums')     _ -> desugar $ IndexedExpr True expr [Subscript nums]  -- TODO: Allow nested MultiSubscript and MultiSuperscript@@ -174,21 +173,19 @@  desugar (CollectionExpr (ElementExpr elm:inners)) = do   elm' <- desugar elm-  (CollectionExpr inners') <- desugar (CollectionExpr inners)+  CollectionExpr inners' <- desugar (CollectionExpr inners)   return $ CollectionExpr (ElementExpr elm':inners')  desugar (CollectionExpr (SubCollectionExpr sub:inners)) = do   sub' <- desugar sub-  (CollectionExpr inners') <- desugar (CollectionExpr inners)+  CollectionExpr inners' <- desugar (CollectionExpr inners)   return $ CollectionExpr (SubCollectionExpr sub':inners')  desugar (VectorExpr exprs) =   VectorExpr <$> mapM desugar exprs -desugar (TensorExpr nsExpr xsExpr supExpr subExpr) = do-  nsExpr' <- desugar nsExpr-  xsExpr' <- desugar xsExpr-  return $ TensorExpr nsExpr' xsExpr' supExpr subExpr+desugar (TensorExpr nsExpr xsExpr) =+  TensorExpr <$> desugar nsExpr <*> desugar xsExpr  desugar (LambdaExpr names expr) = do   let (rtnames, rhnames) = span (\case@@ -289,6 +286,25 @@ desugar (BinaryOpExpr op expr1 expr2) =   (\x y -> makeApply (func op) [x, y]) <$> desugar expr1 <*> desugar expr2 +-- section+desugar (SectionExpr op Nothing Nothing) = do+  x <- fresh+  y <- fresh+  desugar $ LambdaExpr [TensorArg x, TensorArg y]+                       (BinaryOpExpr op (stringToVarExpr x) (stringToVarExpr y))++desugar (SectionExpr op Nothing (Just expr2)) = do+  x <- fresh+  desugar $ LambdaExpr [TensorArg x]+                       (BinaryOpExpr op (stringToVarExpr x) expr2)++desugar (SectionExpr op (Just expr1) Nothing) = do+  y <- fresh+  desugar $ LambdaExpr [TensorArg y]+                       (BinaryOpExpr op expr1 (stringToVarExpr y))++desugar SectionExpr{} = throwError $ Default "Cannot reach here: section with both arguments"+ desugar (SeqExpr expr0 expr1) =   SeqExpr <$> desugar expr0 <*> desugar expr1 @@ -356,16 +372,19 @@    collectNames patterns = S.unions $ map collectName patterns     collectName :: EgisonPattern -> Set String-   collectName (NotPat pattern) = collectName pattern+   collectName (ForallPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2+   collectName (InfixPat _ pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2+   collectName (NotPat pattern)  = collectName pattern    collectName (AndPat patterns) = collectNames patterns+   collectName (OrPat patterns)  = collectNames patterns    collectName (TuplePat patterns) = collectNames patterns+   collectName (InductiveOrPApplyPat _ patterns) = collectNames patterns    collectName (InductivePat _ patterns) = collectNames patterns    collectName (PApplyPat _ patterns) = collectNames patterns    collectName (DApplyPat _ patterns) = collectNames patterns    collectName (LoopPat _ (LoopRange _ _ endNumPat) pattern1 pattern2) = collectName endNumPat `S.union` collectName pattern1 `S.union` collectName pattern2    collectName (LetPat _ pattern) = collectName pattern    collectName (IndexedPat (PatVar name) _) = S.singleton $ show name-   collectName (OrPat patterns) = collectNames patterns    collectName (DivPat pattern1 pattern2) = collectName pattern1 `S.union` collectName pattern2    collectName (PlusPat patterns) = collectNames patterns    collectName (MultPat patterns) = collectNames patterns@@ -379,9 +398,14 @@ 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+desugarPattern' (InductiveOrPApplyPat name patterns) = InductiveOrPApplyPat name <$> mapM desugarPattern' patterns desugarPattern' (InductivePat name patterns) = InductivePat name <$> mapM desugarPattern' patterns desugarPattern' (IndexedPat pattern exprs) = IndexedPat <$> desugarPattern' pattern <*> mapM desugar exprs desugarPattern' (PApplyPat expr patterns) = PApplyPat <$> desugar expr <*> mapM desugarPattern' patterns@@ -427,20 +451,17 @@   LoopRange <$> desugar sExpr <*> desugar eExpr <*> desugarPattern' pattern  desugarBindings :: [BindingExpr] -> EgisonM [BindingExpr]-desugarBindings = mapM f-  where f (name, expr) = (name,) <$> desugar expr+desugarBindings = mapM (\(name, expr) -> (name,) <$> desugar expr)  desugarMatchClauses :: [MatchClause] -> EgisonM [MatchClause]-desugarMatchClauses = mapM f-  where f (pattern, expr) = (,) <$> desugarPattern pattern <*> desugar expr+desugarMatchClauses = mapM (\(pattern, expr) -> (,) <$> desugarPattern pattern <*> desugar expr)  desugarPatternDef :: PatternDef -> EgisonM PatternDef desugarPatternDef (pp, matcher, pds) =   (pp,,) <$> desugar matcher <*> desugarPrimitiveDataMatchClauses pds  desugarPrimitiveDataMatchClauses :: [(PrimitiveDataPattern, EgisonExpr)] -> EgisonM [(PrimitiveDataPattern, EgisonExpr)]-desugarPrimitiveDataMatchClauses = mapM f-  where f (pd, expr) = (pd,) <$> desugar expr+desugarPrimitiveDataMatchClauses = mapM (\(pd, expr) -> (pd,) <$> desugar expr)  makeApply :: String -> [EgisonExpr] -> EgisonExpr makeApply func args = ApplyExpr (stringToVarExpr func) (TupleExpr args)

@@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms   #-}  {- | Module      : Language.Egison.MathExpr-Copyright   : Satoshi Egi Licence     : MIT  This module contains functions for mathematical expressions.@@ -15,6 +15,7 @@     , PolyExpr (..)     , TermExpr (..)     , SymbolExpr (..)+    , pattern SingleTerm     -- * Scalar     , mathNormalize'     , mathFold@@ -39,26 +40,32 @@ --  -data ScalarData =-    Div PolyExpr PolyExpr+data ScalarData+  = Div PolyExpr PolyExpr  deriving (Eq) -newtype PolyExpr =-    Plus [TermExpr]+newtype PolyExpr+  = Plus [TermExpr] -data TermExpr =-    Term Integer Monomial+data TermExpr+  = Term Integer Monomial +-- We choose the definition 'monomials' without its coefficients.+-- ex. 2 x^2 y^3 is *not* a monomial. x^2 t^3 is a monomial. type Monomial = [(SymbolExpr, Integer)] -data SymbolExpr =-    Symbol Id String [Index ScalarData]+data SymbolExpr+  = Symbol Id String [Index ScalarData]   | Apply ScalarData [ScalarData]   | Quote ScalarData   | FunctionData ScalarData [ScalarData] [ScalarData] [Index ScalarData] -- fnname argnames args indices  deriving (Eq)  type Id = String++-- Product of a coefficient and a monomial+pattern SingleTerm :: Integer -> Monomial -> ScalarData+pattern SingleTerm coeff mono = Div (Plus [Term coeff mono]) (Plus [Term 1 []])  instance Eq PolyExpr where   (Plus []) == (Plus []) = True

@@ -1,6 +1,5 @@ {- | Module      : Language.Egison.MathOutput-Copyright   : Satoshi Egi Licence     : MIT  This module provides translation from mathematical Egison expression into

@@ -4,7 +4,6 @@  {- | Module      : Language.Egison.Parser-Copyright   : Satoshi Egi Licence     : MIT  This module provide Egison parser.@@ -46,7 +45,7 @@  import           Language.Egison.AST import           Language.Egison.Desugar-import           Language.Egison.Types+import           Language.Egison.Data import           Paths_egison            (getDataFileName)  readTopExprs :: String -> EgisonM [EgisonTopExpr]@@ -446,42 +445,35 @@ cApplyExpr = keywordCApply >> CApplyExpr <$> expr <*> expr  applyExpr :: Parser EgisonExpr-applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr)-             <|> applyExpr'--applyExpr' :: Parser EgisonExpr-applyExpr' = do+applyExpr = do   func <- expr-  args <- args+  args <- sepEndBy arg whiteSpace   let vars = lefts args   case vars of     [] -> return . ApplyExpr func . TupleExpr $ rights args     _ | all null vars ->-        let args' = rights args-            args'' = zipWith (curry f) args (annonVars 1 (length args))-            args''' = map (VarExpr . stringToVar . either id id) args''-        in return $ ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (lefts args'')) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'+        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' = rights args-                   args'' = zipWith (curry g) args (annonVars (n + 1) (length args))-                   args''' = map (VarExpr . stringToVar . either id id) args''-               in return $ ApplyExpr (LambdaExpr (map ScalarArg (rights args'')) (LambdaExpr (map ScalarArg (annonVars 1 n)) $ ApplyExpr func $ TupleExpr args''')) $ TupleExpr args'+               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-  args = sepEndBy arg whiteSpace   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 (Left _, var)  = Left var-  f (Right _, var) = Right var-  g (Left arg, _)  = Left (':':arg)-  g (Right _, var) = Right var+  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)@@ -514,7 +506,7 @@ generateTensorExpr = keywordGenerateTensor >> GenerateTensorExpr <$> expr <*> expr  tensorExpr :: Parser EgisonExpr-tensorExpr = keywordTensor >> TensorExpr <$> expr <*> expr <*> option (CollectionExpr []) expr <*> option (CollectionExpr []) expr+tensorExpr = keywordTensor >> TensorExpr <$> expr <*> expr  tensorContractExpr :: Parser EgisonExpr tensorContractExpr = keywordTensorContract >> TensorContractExpr <$> expr <*> expr@@ -684,22 +676,17 @@ floatExpr = FloatExpr <$> positiveFloatLiteral  integerExpr :: Parser EgisonExpr-integerExpr = IntegerExpr <$> integerLiteral'--integerLiteral' :: Parser Integer-integerLiteral' = sign <*> positiveIntegerLiteral--positiveIntegerLiteral :: Parser Integer-positiveIntegerLiteral = read <$> many1 digit+integerExpr = IntegerExpr <$> integerLiteral  positiveFloatLiteral :: Parser Double positiveFloatLiteral = do-  n <- positiveIntegerLiteral+  n <- integerLiteral   char '.'   mStr <- many1 digit   let m = read mStr   let l = m % (10 ^ fromIntegral (length mStr))-  return (fromRational (fromIntegral n + l) :: Double)+  if n < 0 then return (fromRational (fromIntegral n - l) :: Double)+           else return (fromRational (fromIntegral n + l) :: Double)  -- -- Tokens@@ -738,7 +725,6 @@   , "load"   , "if"   , "seq"-  , "apply"   , "capply"   , "lambda"   , "memoized-lambda"@@ -816,7 +802,6 @@ keywordAnd                  = reserved "and" keywordOr                   = reserved "or" keywordSeq                  = reserved "seq"-keywordApply                = reserved "apply" keywordCApply               = reserved "capply" keywordLambda               = reserved "lambda" keywordMemoizedLambda       = reserved "memoized-lambda"

@@ -1,8 +1,8 @@ {-# LANGUAGE TupleSections    #-}+{-# LANGUAGE NamedFieldPuns   #-}  {- | Module      : Language.Egison.ParserNonS-Copyright   : Satoshi Egi Licence     : MIT  This module provides the new parser of Egison.@@ -26,11 +26,12 @@  import           Control.Applicative            (pure, (*>), (<$>), (<$), (<*), (<*>)) import           Control.Monad.Except           (liftIO, throwError)-import           Control.Monad.State            (unless)+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)+import           Data.List                      (find, groupBy, insertBy) import           Data.Maybe                     (fromJust, isJust, isNothing) import           Data.Text                      (pack) @@ -45,12 +46,13 @@  import           Language.Egison.AST import           Language.Egison.Desugar-import           Language.Egison.Types+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 @@ -107,10 +109,21 @@ -- Parser -- -type Parser = Parsec CustomError String+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 EgisonBinOp EgisonBinOp+  = IllFormedSection Infix Infix   | IllFormedDefine   deriving (Eq, Ord) @@ -125,10 +138,10 @@   doParse :: Parser a -> String -> Either EgisonError a-doParse p input = either (throwError . fromParsecError) return $ parse p "egison" input-  where-    fromParsecError :: ParseErrorBundle String CustomError -> EgisonError-    fromParsecError = Parser . errorBundlePretty+doParse p input =+  case parse (evalStateT p initialPState) "egison" input of+    Left e  -> throwError (Parser (errorBundlePretty e))+    Right r -> return r  -- -- Expressions@@ -137,6 +150,7 @@ topExpr :: Parser EgisonTopExpr topExpr = Load     <$> (reserved "load" >> stringLiteral)       <|> LoadFile <$> (reserved "loadFile" >> stringLiteral)+      <|> infixExpr       <|> defineOrTestExpr       <?> "toplevel expression" @@ -146,6 +160,45 @@   | 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@@ -168,8 +221,11 @@     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 == "%" = do+      | repr op == "*" || repr op == "%" || repr op == "$" = do         args <- exprToArgs e         case args of           ScalarArg var : args -> return $ Function (Var [var] []) args@@ -188,6 +244,7 @@     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@@ -200,70 +257,72 @@       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 whereDefs+  bindings <- optional (reserved "where" >> alignSome binding)   return $ case bindings of              Nothing -> body              Just bindings -> LetRecExpr bindings body-  where-    whereDefs = do-      pos <- reserved "where" >> L.indentLevel-      some (L.indentGuard sc EQ pos >> binding)  exprWithoutWhere :: Parser EgisonExpr exprWithoutWhere =        ifExpr    <|> patternMatchExpr    <|> lambdaExpr+   <|> lambdaLikeExpr    <|> letExpr    <|> withSymbolsExpr    <|> doExpr    <|> ioExpr+   <|> capplyExpr    <|> matcherExpr    <|> algebraicDataMatcherExpr-   <|> memoizedLambdaExpr-   <|> procedureExpr-   <|> generateTensorExpr+   <|> arrayOpExpr    <|> tensorExpr+   <|> tensorOpExpr    <|> functionExpr+   <|> refsExpr    <|> opExpr    <?> "expression"  -- Also parses atomExpr opExpr :: Parser EgisonExpr opExpr = do-  pos <- L.indentLevel-  makeExprParser atomOrApplyExpr (makeTable pos)+  infixes <- exprInfix <$> get+  makeExprParser atomOrApplyExpr (makeExprTable infixes) -makeTable :: Pos -> [[Operator Parser EgisonExpr]]-makeTable pos =+makeExprTable :: [Infix] -> [[Operator Parser EgisonExpr]]+makeExprTable infixes =   -- prefixes have top priority   let prefixes = [ [ Prefix (unary "-")                    , Prefix (unary "!") ] ]-      -- Generate binary operator table from |reservedBinops|-      binops = map (map binOpToOperator)-        (groupBy (\x y -> priority x == priority y) reservedBinops)-   in prefixes ++ binops+      -- 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 :: String -> Parser (EgisonExpr -> EgisonExpr -> EgisonExpr)-    binary sym = do-      -- TODO: Is this indentation guard necessary?-      op <- try (L.indentGuard sc GT pos >> binOpLiteral 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 -    binOpToOperator :: EgisonBinOp -> Operator Parser EgisonExpr-    binOpToOperator op = case assoc op of-                           LeftAssoc  -> InfixL (binary (repr op))-                           RightAssoc -> InfixR (binary (repr op))-                           NonAssoc   -> InfixN (binary (repr op))+    toOperator :: Infix -> Operator Parser EgisonExpr+    toOperator = infixToOperator binary   ifExpr :: Parser EgisonExpr@@ -282,22 +341,21 @@  -- Parse more than 1 match clauses. matchClauses1 :: Parser [MatchClause]-matchClauses1 = do-  pos <- L.indentLevel+matchClauses1 =   -- If the first bar '|' is missing, then it is expected to have only one match clause.-  (lookAhead (symbol "|") >> some (matchClause pos)) <|> (:[]) <$> matchClauseWithoutBar+  (lookAhead (symbol "|") >> alignSome matchClause) <|> (:[]) <$> matchClauseWithoutBar   where     matchClauseWithoutBar :: Parser MatchClause     matchClauseWithoutBar = (,) <$> pattern <*> (symbol "->" >> expr) -    matchClause :: Pos -> Parser MatchClause-    matchClause pos = (,) <$> (L.indentGuard sc EQ pos >> symbol "|" >> 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))+  <|> try (LambdaExpr <$> some arg <* symbol "->") <*> expr   <|> PatternFunctionExpr <$> some lowerId <*> (symbol "=>" >> pattern))   <?> "lambda or pattern function expression"   where@@ -306,16 +364,22 @@       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-  pos   <- reserved "let" >> L.indentLevel-  binds <- oneLiner <|> some (L.indentGuard sc EQ pos *> binding)+  binds <- reserved "let" >> oneLiner <|> alignSome binding   body  <- reserved "in" >> expr   return $ LetRecExpr binds body   where@@ -338,8 +402,7 @@  doExpr :: Parser EgisonExpr doExpr = do-  pos   <- reserved "do" >> L.indentLevel-  stmts <- oneLiner <|> some (L.indentGuard sc EQ pos >> statement)+  stmts <- reserved "do" >> oneLiner <|> alignSome statement   return $ case last stmts of              ([], retExpr@(ApplyExpr (VarExpr (Var ["return"] _)) _)) ->                DoExpr (init stmts) retExpr@@ -354,22 +417,22 @@ ioExpr :: Parser EgisonExpr ioExpr = IoExpr <$> (reserved "io" >> expr) +capplyExpr :: Parser EgisonExpr+capplyExpr = CApplyExpr <$> (reserved "capply" >> atomExpr) <*> atomExpr+ matcherExpr :: Parser EgisonExpr matcherExpr = do   reserved "matcher"-  pos  <- L.indentLevel   -- Assuming it is unlikely that users want to write matchers with only 1   -- pattern definition, the first '|' (bar) is made indispensable in matcher   -- expression.-  info <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef)-  return $ MatcherExpr info+  MatcherExpr <$> alignSome (symbol "|" >> patternDef)   where     patternDef :: Parser (PrimitivePatPattern, EgisonExpr, [(PrimitiveDataPattern, EgisonExpr)])     patternDef = do       pp <- ppPattern       returnMatcher <- reserved "as" >> expr <* reserved "with"-      pos <- L.indentLevel-      datapat <- some (L.indentGuard sc EQ pos >> symbol "|" >> dataCases)+      datapat <- alignSome (symbol "|" >> dataCases)       return (pp, returnMatcher, datapat)      dataCases :: Parser (PrimitiveDataPattern, EgisonExpr)@@ -378,39 +441,47 @@ algebraicDataMatcherExpr :: Parser EgisonExpr algebraicDataMatcherExpr = do   reserved "algebraicDataMatcher"-  pos  <- L.indentLevel-  defs <- some (L.indentGuard sc EQ pos >> symbol "|" >> patternDef)-  return $ AlgebraicDataMatcherExpr defs+  AlgebraicDataMatcherExpr <$> alignSome (symbol "|" >> patternDef)   where-    patternDef :: Parser (String, [EgisonExpr])-    patternDef = do-      pos <- L.indentLevel-      patternCtor <- lowerId-      args <- many (L.indentGuard sc GT pos >> atomExpr)-      return (patternCtor, args)--memoizedLambdaExpr :: Parser EgisonExpr-memoizedLambdaExpr = MemoizedLambdaExpr <$> (reserved "memoizedLambda" >> many lowerId) <*> (symbol "->" >> expr)--procedureExpr :: Parser EgisonExpr-procedureExpr = ProcedureExpr <$> (reserved "procedure" >> many lowerId) <*> (symbol "->" >> expr)+    patternDef = indentBlock lowerId atomExpr -generateTensorExpr :: Parser EgisonExpr-generateTensorExpr = GenerateTensorExpr <$> (reserved "generateTensor" >> atomExpr) <*> 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-                        <*> option (CollectionExpr []) atomExpr-                        <*> option (CollectionExpr []) 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 "[" >> (try betweenOrFromExpr <|> elementsExpr)+collectionExpr = symbol "[" >> betweenOrFromExpr <|> elementsExpr   where     betweenOrFromExpr = do-      start <- expr <* symbol ".."+      start <- try (expr <* symbol "..")       end   <- optional expr <* symbol "]"       case end of         Just end' -> return $ makeApply' "between" [start, end']@@ -436,34 +507,26 @@     -- Sections without the left operand: eg. (+), (+ 1)     leftSection :: Parser EgisonExpr     leftSection = do-      op   <- choice $ map (binOpLiteral . repr) reservedBinops-      rarg <- optional expr+      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 (makeLambda op Nothing rarg)+        _ -> return (SectionExpr op Nothing rarg)      -- Sections with the left operand but lacks the right operand: eg. (1 +)     rightSection :: Parser EgisonExpr     rightSection = do-      larg <- opExpr-      op   <- choice $ map (binOpLiteral . repr) reservedBinops+      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 (makeLambda op (Just larg) Nothing)--    -- TODO(momohatt): Generate fresh variable for argument-    makeLambda :: EgisonBinOp -> Maybe EgisonExpr -> Maybe EgisonExpr -> EgisonExpr-    makeLambda op Nothing Nothing =-      LambdaExpr [TensorArg ":x", TensorArg ":y"]-                 (BinaryOpExpr op (stringToVarExpr ":x") (stringToVarExpr ":y"))-    makeLambda op Nothing (Just rarg) =-      LambdaExpr [TensorArg ":x"] (BinaryOpExpr op (stringToVarExpr ":x") rarg)-    makeLambda op (Just larg) Nothing =-      LambdaExpr [TensorArg ":y"] (BinaryOpExpr op larg (stringToVarExpr ":y"))+        _ -> return (SectionExpr op (Just larg) Nothing)  arrayExpr :: Parser EgisonExpr arrayExpr = ArrayExpr <$> between (symbol "(|") (symbol "|)") (sepEndBy expr comma)@@ -499,9 +562,7 @@  atomOrApplyExpr :: Parser EgisonExpr atomOrApplyExpr = do-  pos <- L.indentLevel-  func <- atomExpr-  args <- many (L.indentGuard sc GT pos *> atomExpr)+  (func, args) <- indentBlock atomExpr atomExpr   return $ case args of              [] -> func              _  -> makeApply func args@@ -511,7 +572,6 @@ atomExpr = do   e <- atomExpr'   override <- isNothing <$> optional (try (string "..." <* lookAhead index))-  -- TODO(momohatt): "..." (override of index) collides with ContPat   indices <- many index   return $ case indices of              [] -> e@@ -557,17 +617,19 @@  pattern :: Parser EgisonPattern pattern = letPattern+      <|> forallPattern       <|> loopPattern       <|> opPattern       <?> "pattern"  letPattern :: Parser EgisonPattern-letPattern = do-  pos   <- reserved "let" >> L.indentLevel-  binds <- some (L.indentGuard sc EQ pos *> binding)-  body  <- reserved "in" >> pattern-  return $ LetPat binds body+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@@ -590,31 +652,33 @@   return $ foldr SeqConsPat SeqNilPat pats  opPattern :: Parser EgisonPattern-opPattern = makeExprParser applyOrAtomPattern table+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-    table :: [[Operator Parser EgisonPattern]]-    table =-      [ [ Prefix (NotPat <$ symbol "!") ]-      -- 5-      , [ InfixR (inductive2 "cons" "::" )-        , InfixR (inductive2 "join" "++") ]-      -- 3-      , [ InfixR (binary AndPat "&") ]-      -- 2-      , [ InfixR (binary OrPat  "|") ]-      ]-    inductive2 name sym = (\x y -> InductivePat name [x, y]) <$ patOperator sym-    binary name sym     = (\x y -> name [x, y]) <$ patOperator sym+    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-  pos <- L.indentLevel-  func <- atomPattern-  args <- many (L.indentGuard sc GT pos *> atomPattern)-  case (func, args) of-    (_,                 []) -> return func-    (InductivePat x [], _)  -> return $ InductivePat x args-    _                       -> error (show (func, args))+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@@ -627,8 +691,9 @@  -- Atomic pattern without index atomPattern' :: Parser EgisonPattern-atomPattern' = WildCard <$   symbol "_"+atomPattern' = WildCard <$  symbol "_"            <|> PatVar   <$> patVarLiteral+           <|> NotPat   <$> (symbol "!" >> atomPattern)            <|> ValuePat <$> (char '#' >> atomExpr)            <|> InductivePat "nil" [] <$ (symbol "[" >> symbol "]")            <|> InductivePat <$> lowerId <*> pure []@@ -642,21 +707,24 @@  ppPattern :: Parser PrimitivePatPattern ppPattern = PPInductivePat <$> lowerId <*> many ppAtom-        <|> makeExprParser ppAtom table+        <|> do ops <- patternInfix <$> get+               makeExprParser ppAtom (makeTable ops)         <?> "primitive pattern pattern"   where-    table :: [[Operator Parser PrimitivePatPattern]]-    table =-      [ [ InfixR (inductive2 "cons" "::" )-        , InfixR (inductive2 "join" "++") ]-      ]-    inductive2 name sym = (\x y -> PPInductivePat name [x, y]) <$ operator sym+    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 <$> (symbol "#$" >> lowerId)-         <|> PPInductivePat "nil" [] <$ brackets sc+         <|> PPValuePat <$> (string "#$" >> lowerId)+         <|> PPInductivePat "nil" [] <$ (symbol "[" >> symbol "]")          <|> makeTupleOrParen ppPattern PPTuplePat  pdPattern :: Parser PrimitiveDataPattern@@ -671,7 +739,7 @@       ]     pdAtom :: Parser PrimitiveDataPattern     pdAtom = PDWildCard    <$ symbol "_"-         <|> PDPatVar      <$> (symbol "$" >> lowerId)+         <|> PDPatVar      <$> (char '$' >> lowerId)          <|> PDConstantPat <$> constantExpr          <|> PDEmptyPat    <$ (symbol "[" >> symbol "]")          <|> makeTupleOrParen pdPattern PDTuplePat@@ -717,13 +785,16 @@ patVarLiteral :: Parser Var patVarLiteral = stringToVar <$> (char '$' >> lowerId) -binOpLiteral :: String -> Parser EgisonBinOp-binOpLiteral sym =-  try (do wedge <- optional (char '!')-          opSym <- operator' sym-          let opInfo = fromJust $ find ((== opSym) . repr) reservedBinops+-- 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 })-   <?> "binary operator"+   <?> "infix"   where     -- operator without try     operator' :: String -> Parser String@@ -732,24 +803,32 @@ reserved :: String -> Parser () reserved w = (lexeme . try) (string w *> notFollowedBy identChar) -symbol :: String -> Parser String-symbol sym = try $ L.symbol sc sym+symbol :: String -> Parser ()+symbol sym = try (L.symbol sc sym) >> pure ()  operator :: String -> Parser String operator sym = try $ string sym <* notFollowedBy opChar <* sc -patOperator :: String -> Parser String-patOperator sym = try $ string sym <* notFollowedBy patOpChar <* 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 "%^&*-+\\|:<>.?/'!#@$"+opChar = oneOf ("%^&*-+\\|:<>.?!/'#@$" ++ "∧")  -- Characters that can consist pattern operators.--- ! # @ $ are omitted because they can appear at the beginning of atomPattern+-- ! ? # @ $ are omitted because they can appear at the beginning of atomPattern patOpChar :: Parser Char-patOpChar = oneOf "%^&*-+\\|:<>.?/'"+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 "..."@@ -771,7 +850,7 @@ brackets :: Parser a -> Parser a brackets  = between (symbol "[") (symbol "]") -comma :: Parser String+comma :: Parser () comma = symbol ","  -- Notes on identifiers:@@ -819,8 +898,7 @@   , "if"   , "then"   , "else"-  , "seq"-  , "apply"+  -- , "seq"   , "capply"   , "memoizedLambda"   , "cambda"@@ -830,7 +908,7 @@   , "where"   , "withSymbols"   , "loop"-  , "of"+  , "forall"   , "match"   , "matchDFS"   , "matchAll"@@ -843,9 +921,15 @@   , "something"   , "undefined"   , "algebraicDataMatcher"+  , "generateArray"+  , "arrayBounds"+  , "arrayRef"   , "generateTensor"   , "tensor"   , "contract"+  , "tensorMap"+  , "tensorMap2"+  , "transpose"   , "subrefs"   , "subrefs!"   , "suprefs"@@ -853,6 +937,9 @@   , "userRefs"   , "userRefs!"   , "function"+  , "infixl"+  , "infixr"+  , "infix"   ]  --@@ -872,3 +959,34 @@  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)

@@ -3,7 +3,6 @@  {- | Module      : Language.Egison.PrettyPrint-Copyright   : Satoshi Egi Licence     : MIT  This module contains pretty printing for Egison syntax@@ -24,7 +23,7 @@  import           Language.Egison.AST import           Language.Egison.MathExpr-import           Language.Egison.Types+import           Language.Egison.Data  -- -- Pretty printing for Non-S syntax@@ -35,83 +34,142 @@  instance Pretty EgisonTopExpr where   pretty (Define x (LambdaExpr args body)) =-    pretty x <+> hsep (map pretty args) <+> pretty ":=" <> nest 2 (hardline <> pretty body)-  pretty (Define x expr) = pretty x <+> pretty ":=" <> nest 2 (softline <> pretty expr)+    hsep (pretty x : map pretty args) <+> group (pretty ":=" <>+      flatAlt (nest 2 (hardline <> pretty body)) (space <> pretty body))+  pretty (Define x expr) =+    pretty x <+> group (pretty ":=" <>+      flatAlt (nest 2 (hardline <> pretty expr)) (space <> pretty expr))   pretty (Test expr) = pretty expr   pretty (LoadFile file) = pretty "loadFile" <+> pretty (show file)   pretty (Load lib) = pretty "load" <+> pretty (show lib)+  pretty _ = error "Unsupported topexpr"  instance Pretty EgisonExpr where-  pretty (CharExpr x)    = squote <> pretty x <> squote-  pretty (StringExpr x)  = dquote <> pretty x <> dquote+  -- Use |viaShow| to correctly handle escaped characters+  pretty (CharExpr x)    = viaShow x+  pretty (StringExpr x)  = viaShow x   pretty (BoolExpr x)    = pretty x   pretty (IntegerExpr x) = pretty x   pretty (FloatExpr x)   = pretty x   pretty (VarExpr x)     = pretty x+  pretty FreshVarExpr    = pretty "#"+  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+  pretty (SuprefsExpr b e1 e2) =+    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 -  pretty (InductiveDataExpr c xs) = nest 2 (pretty c <+> fillSep (map pretty xs))+  pretty (InductiveDataExpr c xs) = nest 2 (sep (pretty c : map pretty' xs))    pretty (TupleExpr xs) = tupled (map pretty xs)-  pretty (CollectionExpr xs) = list (map pretty xs)+  pretty (CollectionExpr xs)+    | 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 y)          = pretty "\\" <> hsep (map pretty xs) <+> pretty "->" <> nest 2 (softline <> pretty y)-  pretty (PatternFunctionExpr xs y) = pretty "\\" <> hsep (map pretty xs) <+> pretty "=>" <> softline <> pretty y+  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 (IfExpr x y z) =-    pretty "if" <+> pretty x-               <> nest 2 (softline <> pretty "then" <+> pretty y <>-                          softline <> pretty "else" <+> pretty 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)))   pretty (LetRecExpr bindings body) =-    hang 1 (pretty "let" <+> align (vsep (map pretty bindings)) <> hardline <> pretty "in" <+> pretty 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 (MatchExpr BFSMode tgt matcher clauses) =-    pretty "match"       <+> pretty tgt <+> prettyMatch matcher clauses+    nest 2 (pretty "match"       <+> pretty tgt <+> prettyMatch matcher clauses)   pretty (MatchExpr DFSMode tgt matcher clauses) =-    pretty "matchDFS"    <+> pretty tgt <+> prettyMatch matcher clauses+    nest 2 (pretty "matchDFS"    <+> pretty tgt <+> prettyMatch matcher clauses)   pretty (MatchAllExpr BFSMode tgt matcher clauses) =-    pretty "matchAll"    <+> pretty tgt <+> prettyMatch matcher clauses+    nest 2 (pretty "matchAll"    <+> pretty tgt <+> prettyMatch matcher clauses)   pretty (MatchAllExpr DFSMode tgt matcher clauses) =-    pretty "matchAllDFS" <+> pretty tgt <+> prettyMatch matcher clauses+    nest 2 (pretty "matchAllDFS" <+> pretty tgt <+> prettyMatch matcher clauses)   pretty (MatchLambdaExpr matcher clauses) =-    pretty "\\match"     <+> prettyMatch matcher clauses+    nest 2 (pretty "\\match"     <+> prettyMatch matcher clauses)   pretty (MatchAllLambdaExpr matcher clauses) =-    pretty "\\matchAll"  <+> prettyMatch matcher clauses+    nest 2 (pretty "\\matchAll"  <+> prettyMatch matcher clauses)    pretty (MatcherExpr patDefs) =-    pretty "matcher" <> (nest 2 (hardline <> align (vsep (map prettyPatternDef patDefs))))+    nest 2 (pretty "matcher" <> hardline <> align (vsep (map prettyPatDef patDefs)))+      where+        prettyPatDef (pppat, expr, body) =+          nest 2 (pipe <+> pretty pppat <+> pretty "as" <+>+            group (pretty expr) <+> pretty "with" <> hardline <>+              align (vsep (map prettyPatBody body)))+        prettyPatBody (pdpat, expr) =+          pipe <+> pretty pdpat <+> pretty "->" <+> pretty expr -  pretty (PartialExpr n x) =-    pretty n <> pretty "#" <> pretty x-  pretty (PartialVarExpr n) =-    pretty "%" <> pretty n+  pretty (AlgebraicDataMatcherExpr patDefs) =+    nest 2 (pretty "algebraicDataMatcher" <> hardline <> align (vsep (map prettyPatDef patDefs)))+      where+        prettyPatDef (name, exprs) = pipe <+> hsep (pretty name : map pretty exprs) -  pretty (UnaryOpExpr op x) = pretty op <> pretty x+  pretty (QuoteExpr e) = squote <> pretty' e+  pretty (QuoteSymbolExpr e) = pretty '`' <> pretty' e++  pretty (UnaryOpExpr op x@(IntegerExpr _)) = pretty op <> pretty x+  pretty (UnaryOpExpr op x)+    | isAtomOrApp x = pretty op <+> pretty x+    | otherwise     = pretty op <+> parens (pretty x)   -- (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 (repr op) <+> pretty'' y+       else pretty x          <+> pretty (repr 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+       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)) -  -- TODO: Fix display of binding expr for do-  pretty (DoExpr xs y) = pretty "do" <+> pretty xs <> hardline <> pretty y+  pretty (DoExpr xs y) = pretty "do" <+> align (vsep (map prettyDoBinds xs ++ [pretty y]))   pretty (IoExpr x) = pretty "io" <+> pretty x -  pretty (ApplyExpr x (TupleExpr ys)) = nest 2 (pretty x <+> fillSep (map pretty' ys))+  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 (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 (FlipIndicesExpr _) = error "unreachable"++  pretty (FunctionExpr xs) = pretty "function" <+> tupled (map pretty xs)+   pretty SomethingExpr = pretty "something"   pretty UndefinedExpr = pretty "undefined" +  pretty _ = pretty "REPLACEME"+ instance Pretty Arg where   pretty (ScalarArg x)         = pretty x   pretty (InvertedScalarArg x) = pretty "*" <> pretty x@@ -123,56 +181,191 @@  instance Pretty InnerExpr where   pretty (ElementExpr x) = pretty x-  pretty (SubCollectionExpr _) = pretty "undefined" -- error "(please translate manually)"+  pretty (SubCollectionExpr _) = error "Not supported"  instance {-# OVERLAPPING #-} Pretty BindingExpr where-  pretty ([var], expr) = pretty var <+> pretty ":=" <+> pretty expr-  pretty (vars, expr) = tupled (map pretty vars) <+> pretty ":=" <+> pretty expr+  pretty ([var], LambdaExpr args body) =+    hsep (pretty var : map pretty args) <+> group (pretty ":=" <>+      flatAlt (nest 2 (hardline <> pretty body)) (space <> 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 <+> pretty pat <+> pretty "->" <> softline <> pretty expr+  pretty (pat, expr) =+    pipe <+> align (pretty pat) <+> group (pretty "->" <>+      flatAlt (nest 2 (hardline <> pretty expr)) (space <> pretty expr)) +instance (Pretty a, Complex a) => Pretty (Index a) where+  pretty (Subscript i) = pretty '_' <> pretty' i+  pretty (Superscript i) = pretty '~' <> pretty' i+  pretty (SupSubscript i) = pretty "~_" <> pretty' i+  pretty (MultiSubscript i j) = pretty '_' <> pretty' i <> pretty "..._" <> pretty' j+  pretty (MultiSuperscript i j) = pretty '~' <> pretty' i <> pretty "...~" <> pretty' j+  pretty (DFscript _ _) = undefined+  pretty (Userscript i) = pretty '|' <> pretty' i+ instance Pretty EgisonPattern where-  -- TODO: Add parenthesis according to priority   pretty WildCard     = pretty "_"   pretty (PatVar x)   = pretty "$" <> pretty x-  pretty (ValuePat v) = pretty "#" <> pretty v-  pretty (PredPat v)  = pretty "?" <> pretty v+  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)+  -- (p11 op' p12) op p2+  pretty (InfixPat op p1@(InfixPat op' _ _) p2) =+    if priority op > priority op' || priority op == priority op' && assoc op == RightAssoc+       then parens (pretty p1) <+> pretty (repr op) <+> pretty'' p2+       else pretty p1          <+> pretty (repr op) <+> pretty'' p2+  -- p1 op (p21 op' p22)+  pretty (InfixPat op p1 p2@(InfixPat op' _ _)) =+    if priority op > priority op' || priority op == priority op' && assoc op == LeftAssoc+       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 (InductivePat "nil" []) = pretty "[]"-  pretty (InductivePat "cons" [x, y]) = pretty x <+> pretty "::" <+> pretty y-  pretty (InductivePat "join" [x, y]) = pretty x <+> pretty "++" <+> pretty y-  pretty (InductivePat ctor xs) = pretty ctor <+> hsep (map pretty xs)-  pretty (AndPat xs) = pintercalate (pretty "&") (map pretty xs)-  pretty (OrPat xs)  = pintercalate (pretty "|") (map pretty xs)-  pretty (TuplePat xs) = tupled $ map pretty xs-  pretty _            = pretty "hoge"+  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 (VarPat x) = pretty ('~' : x)+  pretty SeqNilPat = pretty "{}"+  pretty (SeqConsPat p1 p2) = listoid "{" "}" (f p1 p2)+    where+      f p1 SeqNilPat = [pretty p1]+      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 _            = pretty "REPLACEME" -pretty' :: EgisonExpr -> Doc ann-pretty' x =-  case x of-    UnaryOpExpr _ _        -> parens $ pretty x-    ApplyExpr _ _          -> parens $ pretty x-    LambdaExpr _ _         -> parens $ pretty x-    IfExpr _ _ _           -> parens $ pretty x-    LetRecExpr _ _         -> parens $ pretty x-    MatchExpr _ _ _ _      -> parens $ pretty x-    MatchLambdaExpr _ _    -> parens $ pretty x-    MatchAllLambdaExpr _ _ -> parens $ pretty x-    _                      -> pretty x+instance Pretty LoopRange where+  pretty (LoopRange from (ApplyExpr (VarExpr (Var ["from"] []))+                                    (ApplyExpr (VarExpr (Var ["-'"] []))+                                               (TupleExpr [_, 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 (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 (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 (PDConstantPat expr) = pretty expr++class Complex a where+  isAtom :: a -> Bool+  isAtomOrApp :: a -> Bool+  isInfix :: a -> Bool++instance Complex EgisonExpr where+  isAtom (IntegerExpr i) | i < 0  = False+  isAtom UnaryOpExpr{}            = False+  isAtom BinaryOpExpr{}           = False+  isAtom ApplyExpr{}              = False+  isAtom LambdaExpr{}             = False+  isAtom CambdaExpr{}             = False+  isAtom ProcedureExpr{}          = False+  isAtom IfExpr{}                 = False+  isAtom LetRecExpr{}             = False+  isAtom SubrefsExpr{}            = False+  isAtom SuprefsExpr{}            = False+  isAtom UserrefsExpr{}           = False+  isAtom WithSymbolsExpr{}        = False+  isAtom MatchExpr{}              = False+  isAtom MatchAllExpr{}           = False+  isAtom MatchLambdaExpr{}        = False+  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+  isAtom TensorContractExpr{}     = False+  isAtom TensorMapExpr{}          = False+  isAtom TensorMap2Expr{}         = False+  isAtom TransposeExpr{}          = False+  isAtom _                        = True++  isAtomOrApp ApplyExpr{} = True+  isAtomOrApp e           = isAtom e++  isInfix BinaryOpExpr{}  = True+  isInfix _               = False++instance Complex EgisonPattern where+  isAtom (LetPat _ _)        = False+  isAtom (InductivePat _ []) = True+  isAtom (InductivePat _ _)  = False+  isAtom (InfixPat _ _ _)    = False+  isAtom (LoopPat _ _ _ _)   = False+  isAtom _                   = True++  isAtomOrApp PApplyPat{} = True+  isAtomOrApp e           = isAtom e++  isInfix (InfixPat _ _ _)   = True+  isInfix _                  = False++instance Complex PrimitiveDataPattern where+  isAtom (PDInductivePat _ []) = True+  isAtom (PDInductivePat _ _)  = False+  isAtom (PDConsPat _ _)       = False+  isAtom (PDSnocPat _ _)       = False+  isAtom _                     = True++  isAtomOrApp = isAtom++  isInfix (PDConsPat _ _) = True+  isInfix _               = False++pretty' :: (Pretty a, Complex a) => a -> Doc ann+pretty' x | isAtom x  = pretty x+          | otherwise = parens $ pretty x++pretty'' :: (Pretty a, Complex a) => a -> Doc ann+pretty'' x | isAtomOrApp x || isInfix x = pretty x+           | otherwise                  = parens $ pretty x++-- Display "hoge" instead of "() := hoge"+prettyDoBinds :: BindingExpr -> Doc ann+prettyDoBinds ([], expr) = pretty expr+prettyDoBinds (vs, expr) = pretty (vs, expr)+ prettyMatch :: EgisonExpr -> [MatchClause] -> Doc ann prettyMatch matcher clauses =-  pretty "as" <+> group (pretty matcher) <+> pretty "with" <>-    (nest 2 (hardline <> align (vsep (map pretty clauses))))--prettyPatternDef :: PatternDef -> Doc ann-prettyPatternDef _ = pretty "undefined"+  pretty "as" <> group (flatAlt (hardline <> pretty matcher) (space <> pretty matcher) <+> pretty "with") <> hardline <>+    align (vsep (map pretty clauses))  listoid :: String -> String -> [Doc ann] -> Doc ann-listoid lp rp elems = encloseSep (pretty lp) (pretty rp) (comma <> space) elems+listoid lp rp elems =+  encloseSep (pretty lp) (pretty rp) (comma <> space) elems -pintercalate :: Doc ann -> [Doc ann] -> Doc ann-pintercalate sep elems = encloseSep emptyDoc emptyDoc (space <> sep <> space) elems+-- Just like |fillSep|, but does not break the atomicity of grouped Docs+fillSepAtom :: [Doc ann] -> Doc ann+fillSepAtom [] = emptyDoc+fillSepAtom [x] = x+fillSepAtom (x:xs) = x <> fillSepAtom' xs+  where+    fillSepAtom' [] = emptyDoc+    fillSepAtom' (x:xs) =+      group (flatAlt (hardline <> x) (space <> x)) <> fillSepAtom' xs  -- -- Pretty printer for S-expression@@ -247,7 +440,7 @@   prettyS Something = "something"   prettyS Undefined = "undefined"   prettyS World = "#<world>"-  prettyS EOF = "#<eof>"+  prettyS _ = "(not supported)"  instance PrettyS Var where   prettyS = show@@ -255,7 +448,7 @@ instance PrettyS VarWithIndices where   prettyS = show -instance PrettyS EgisonBinOp where+instance PrettyS Infix where   prettyS = repr  instance PrettyS InnerExpr where@@ -354,6 +547,7 @@   prettyS (PlusPat pats) = "(+" ++ concatMap ((" " ++) . prettyS) pats   prettyS (MultPat pats) = "(*" ++ concatMap ((" " ++) . prettyS) pats   prettyS (PowerPat pat pat') = "(" ++ prettyS pat ++ " ^ " ++ prettyS pat' ++ ")"+  prettyS _ = "(not supported)"  instance PrettyS LoopRange where   prettyS (LoopRange start (ApplyExpr (VarExpr (Var ["from"] [])) (ApplyExpr _ (TupleExpr (x:_)))) endPat) =

@@ -4,7 +4,6 @@  {- | Module      : Language.Egison.Primitives-Copyright   : Satoshi Egi Licence     : MIT  This module provides primitive functions in Egison.@@ -42,10 +41,11 @@  import           Language.Egison.AST import           Language.Egison.Core+import           Language.Egison.Data import           Language.Egison.Parser import           Language.Egison.Pretty-import           Language.Egison.Types import           Language.Egison.MathExpr+import           Language.Egison.Types import           Language.Egison.Tensor  primitiveEnv :: IO Env@@ -182,7 +182,7 @@              , ("b.acosh", floatUnaryOp acosh)              , ("b.atanh", floatUnaryOp atanh) -             , ("tensorSize", tensorSize')+             , ("tensorShape", tensorShape')              , ("tensorToList", tensorToList')              , ("dfOrder", dfOrder') @@ -236,7 +236,7 @@              , ("from-math-expr", fromScalarData)              , ("to-math-expr", toScalarData)              , ("to-math-expr'", toScalarData)-             , ("tensor-size", tensorSize')+             , ("tensor-shape", tensorShape')              , ("tensor-to-list", tensorToList')              , ("df-order", dfOrder')              , ("uncons-string", unconsString)@@ -354,11 +354,11 @@ -- Tensor -- -tensorSize' :: PrimitiveFunc-tensorSize' = oneArg' tensorSize''+tensorShape' :: PrimitiveFunc+tensorShape' = oneArg' tensorShape''  where-  tensorSize'' (TensorData (Tensor ns _ _)) = return . Collection . Sq.fromList $ map toEgison ns-  tensorSize'' _ = return . Collection $ Sq.fromList []+  tensorShape'' (TensorData (Tensor ns _ _)) = return . Collection . Sq.fromList $ map toEgison ns+  tensorShape'' _ = return . Collection $ Sq.fromList []  tensorToList' :: PrimitiveFunc tensorToList' = oneArg' tensorToList''

@@ -1,6 +1,5 @@ {- | Module      : Language.Egison.Tensor-Copyright   : Satoshi Egi Licence     : MIT  This module contains functions for tensors.@@ -10,12 +9,11 @@     (     -- * Tensor       initTensor-    , tSize     , tToList     , tIndex     , tref     , enumTensorIndices-    , changeIndexList+    , changeIndex     , tTranspose     , tTranspose'     , tFlipIndices@@ -40,19 +38,19 @@                                             partition, splitAt, (\\))  import           Language.Egison.AST+import           Language.Egison.Data import           Language.Egison.MathExpr-import           Language.Egison.Types  -- -- Tensors -- -initTensor :: [Integer] -> [a] -> [EgisonValue] -> [EgisonValue] -> Tensor a-initTensor ns xs sup sub = Tensor ns (V.fromList xs) (map Superscript sup ++ map Subscript sub)+initTensor :: Shape -> [a] -> Tensor a+initTensor ns xs = Tensor ns (V.fromList xs) [] -tSize :: Tensor a -> [Integer]-tSize (Tensor ns _ _) = ns-tSize (Scalar _)      = []+tShape :: Tensor a -> Shape+tShape (Tensor ns _ _) = ns+tShape (Scalar _)      = []  tToList :: Tensor a -> [a] tToList (Tensor _ xs _) = V.toList xs@@ -86,16 +84,17 @@ tIntRef [] t = return t tIntRef (m:ms) t = tIntRef' m t >>= toTensor >>= tIntRef ms +-- TODO(momohatt): Refactor. tref :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM a tref [] (Tensor [] xs _)   | V.length xs == 1 = fromTensor $ Scalar (xs V.! 0)   | otherwise = throwError =<< EgisonBug "sevaral elements in scalar tensor" <$> getFuncNameStack tref [] t = fromTensor t-tref (Subscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms-tref (Subscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms-tref (Superscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms-tref (Superscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms-tref (SupSubscript (ScalarData (Div (Plus [Term m []]) (Plus [Term 1 []]))):ms) t = tIntRef' m t >>= toTensor >>= tref ms+tref (Subscript    (ScalarData (SingleTerm m [])):ms) t                  = tIntRef' m t >>= toTensor >>= tref ms+tref (Subscript    (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms+tref (Superscript  (ScalarData (SingleTerm m [])):ms) t                  = tIntRef' m t >>= toTensor >>= tref ms+tref (Superscript  (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms+tref (SupSubscript (ScalarData (SingleTerm m [])):ms) t                  = tIntRef' m t >>= toTensor >>= tref ms tref (SupSubscript (ScalarData (Div (Plus []) (Plus [Term 1 []]))):ms) t = tIntRef' 0 t >>= toTensor >>= tref ms tref (Subscript (Tuple [mVal, nVal]):ms) t@(Tensor is _ _) = do   m <- fromEgison mVal@@ -137,14 +136,13 @@ -- ex. -- >>> enumTensorIndices [2,2,2] -- [[1,1,1],[1,1,2],[1,2,1],[1,2,2],[2,1,1],[2,1,2],[2,2,1],[2,2,2]]-enumTensorIndices :: [Integer] -> [[Integer]]+enumTensorIndices :: Shape -> [[Integer]] enumTensorIndices [] = [[]] enumTensorIndices (n:ns) = concatMap (\i -> map (i:) (enumTensorIndices ns)) [1..n] -changeIndexList :: [Index String] -> [EgisonValue] -> [Index String]-changeIndexList idxlist ms = map (\(i, m) -> case i of-                                              Superscript s -> Superscript (s ++ m)-                                              Subscript s -> Subscript (s ++ m)) $ zip idxlist (map show ms)+changeIndex :: Index String -> EgisonValue -> Index String+changeIndex (Superscript s) m = Superscript (s ++ show m)+changeIndex (Subscript s) m   = Subscript (s ++ show m)  transIndex :: [Index EgisonValue] -> [Index EgisonValue] -> [Integer] -> EgisonM [Integer] transIndex [] [] is = return is@@ -155,7 +153,7 @@     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 =<< InconsistentTensorSize <$> getFuncNameStack+transIndex _ _ _ = throwError =<< InconsistentTensorShape <$> getFuncNameStack  tTranspose :: HasTensor a => [Index EgisonValue] -> Tensor a -> EgisonM (Tensor a) tTranspose is t@(Tensor ns _ js) = do@@ -241,11 +239,11 @@   let (cjs, tjs1, tjs2) = h js1 js2   t1' <- tTranspose (cjs ++ tjs1) (Tensor ns1 xs1 js1)   t2' <- tTranspose (cjs ++ tjs2) (Tensor ns2 xs2 js2)-  let cns = take (length cjs) (tSize t1')+  let cns = take (length cjs) (tShape t1')   rts1 <- mapM (`tIntRef` t1') (enumTensorIndices cns)   rts2 <- mapM (`tIntRef` t2') (enumTensorIndices cns)   rts' <- zipWithM (tProduct f) rts1 rts2-  let ret = Tensor (cns ++ tSize (head rts')) (V.concat (map tToVector rts')) (cjs ++ tIndex (head rts'))+  let ret = Tensor (cns ++ tShape (head rts')) (V.concat (map tToVector rts')) (cjs ++ tIndex (head rts'))   tTranspose (uniq (tDiagIndex (js1 ++ js2))) ret  where   h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue])@@ -263,41 +261,29 @@   case filter (\j -> any (p j) js) js of     [] -> return t     xs -> do-      let ys = js \\ (xs ++ map rev xs)-      t2 <- tTranspose (xs ++ map rev xs ++ ys) t-      let (ns1, tmp) = splitAt (length xs) (tSize t2)+      let ys = js \\ (xs ++ map reverseIndex xs)+      t2 <- tTranspose (xs ++ map reverseIndex xs ++ ys) t+      let (ns1, tmp) = splitAt (length xs) (tShape t2)       let (_, ns2) = splitAt (length xs) tmp       ts <- mapM (\is -> tIntRef (is ++ is) t2) (enumTensorIndices ns1)-      return $ Tensor (ns1 ++ ns2) (V.concat (map tToVector ts)) (map g xs ++ ys)+      return $ Tensor (ns1 ++ ns2) (V.concat (map tToVector ts)) (map toSupSubscript xs ++ ys)  where   p :: Index EgisonValue -> Index EgisonValue -> Bool   p (Superscript i) (Subscript j) = i == j   p (Subscript _) _               = False   p _ _                           = False-  rev :: Index EgisonValue -> Index EgisonValue-  rev (Superscript i) = Subscript i-  rev (Subscript i)   = Superscript i-  g :: Index EgisonValue -> Index EgisonValue-  g (Superscript i) = SupSubscript i-  g (Subscript i)   = SupSubscript i tDiag t = return t  tDiagIndex :: [Index EgisonValue] -> [Index EgisonValue] tDiagIndex js =-  let xs = filter (\j -> any (p j) js) js in-  let ys = js \\ (xs ++ map rev xs) in-    map g xs ++ ys+  let xs = filter (\j -> any (p j) js) js+      ys = js \\ (xs ++ map reverseIndex xs)+   in map toSupSubscript xs ++ ys  where   p :: Index EgisonValue -> Index EgisonValue -> Bool   p (Superscript i) (Subscript j) = i == j   p (Subscript _) _               = False   p _ _                           = False-  rev :: Index EgisonValue -> Index EgisonValue-  rev (Superscript i) = Subscript i-  rev (Subscript i)   = Superscript i-  g :: Index EgisonValue -> Index EgisonValue-  g (Superscript i) = SupSubscript i-  g (Subscript i)   = SupSubscript i  tSum :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a) tSum f (Tensor ns1 xs1 js1) t2@Tensor{} = do@@ -306,7 +292,7 @@     (Tensor ns2 xs2 _)       | ns2 == ns1 -> do ys <- V.mapM (uncurry f) (V.zip xs1 xs2)                          return (Tensor ns1 ys js1)-      | otherwise -> throwError =<< InconsistentTensorSize <$> getFuncNameStack+      | otherwise -> throwError =<< InconsistentTensorShape <$> getFuncNameStack  tProduct :: HasTensor a => (a -> a -> EgisonM a) -> Tensor a -> Tensor a -> EgisonM (Tensor a) tProduct f (Tensor ns1 xs1 js1') (Tensor ns2 xs2 js2') = do@@ -329,26 +315,20 @@     _ -> do       t1' <- tTranspose (cjs1 ++ tjs1) t1       t2' <- tTranspose (cjs2 ++ tjs2) t2-      let (cns1, _) = splitAt (length cjs1) (tSize t1')+      let (cns1, _) = splitAt (length cjs1) (tShape t1')       rts' <- mapM (\is -> do rt1 <- tIntRef is t1'                               rt2 <- tIntRef is t2'                               tProduct f rt1 rt2) (enumTensorIndices cns1)-      let ret = Tensor (cns1 ++ tSize (head rts')) (V.concat (map tToVector rts')) (map g cjs1 ++ tIndex (head rts'))-      tTranspose (uniq (map g cjs1 ++ tjs1 ++ tjs2)) ret+      let ret = Tensor (cns1 ++ tShape (head rts')) (V.concat (map tToVector rts')) (map toSupSubscript cjs1 ++ tIndex (head rts'))+      tTranspose (uniq (map toSupSubscript cjs1 ++ tjs1 ++ tjs2)) ret  where   h :: [Index EgisonValue] -> [Index EgisonValue] -> ([Index EgisonValue], [Index EgisonValue], [Index EgisonValue], [Index EgisonValue])   h js1 js2 = let cjs = filter (\j -> any (p j) js2) js1 in-                (cjs, map rev cjs, js1 \\ cjs, js2 \\ map rev cjs)+                (cjs, map reverseIndex cjs, js1 \\ cjs, js2 \\ map reverseIndex cjs)   p :: Index EgisonValue -> Index EgisonValue -> Bool   p (Superscript i) (Subscript j) = i == j   p (Subscript i) (Superscript j) = i == j   p _ _                           = False-  rev :: Index EgisonValue -> Index EgisonValue-  rev (Superscript i) = Subscript i-  rev (Subscript i)   = Superscript i-  g :: Index EgisonValue -> Index EgisonValue-  g (Superscript i) = SupSubscript i-  g (Subscript i)   = SupSubscript i   uniq :: [Index EgisonValue] -> [Index EgisonValue]   uniq []     = []   uniq (x:xs) = x:uniq (delete x xs)@@ -376,8 +356,8 @@     [] -> return t     (m,n):_ -> do       let (hjs, mjs, tjs) = removePairs (m,n) js-      xs' <- mapM (\i -> tref (hjs ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ mjs-                                    ++ [Subscript (ScalarData (Div (Plus [Term i []]) (Plus [Term 1 []])))] ++ tjs) t)+      xs' <- mapM (\i -> tref (hjs ++ [Subscript (ScalarData (SingleTerm i []))] ++ mjs+                                   ++ [Subscript (ScalarData (SingleTerm i []))] ++ tjs) t)                   [1..(ns !! m)]       mapM toTensor xs' >>= tConcat (js !! m) >>= tTranspose (hjs ++ [js !! m] ++ mjs ++ tjs) >>= tContract'  where@@ -438,3 +418,11 @@       (hs, tms) = splitAt m hms  -- [] [i]       ms = tail tms              -- []    in (hs, ms, ts)               -- [] [] []++reverseIndex :: Index EgisonValue -> Index EgisonValue+reverseIndex (Superscript i) = Subscript i+reverseIndex (Subscript i)   = Superscript i++toSupSubscript :: Index EgisonValue -> Index EgisonValue+toSupSubscript (Superscript i) = SupSubscript i+toSupSubscript (Subscript i)   = SupSubscript i

@@ -1,862 +1,35 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE UndecidableInstances       #-}- {- | Module      : Language.Egison.Types-Copyright   : Satoshi Egi Licence     : MIT -This module contains type definitions of Egison Data.+This module contains functions for dynamic type systems. -}  module Language.Egison.Types-    (-    -- * Egison values-      EgisonValue (..)-    , Matcher-    , PrimitiveFunc-    , EgisonHashKey (..)-    , EgisonData (..)-    , Tensor (..)-    , HasTensor (..)-    -- * Scalar-    , symbolScalarData-    , symbolScalarData'-    , getSymId-    , getSymName-    , mathExprToEgison-    , egisonToScalarData-    , extractScalar-    , extractScalar'-    -- * Internal data-    , Object (..)-    , ObjectRef-    , WHNFData (..)-    , Intermediate (..)-    , Inner (..)-    , EgisonWHNF (..)-    -- * Environment-    , Env (..)-    , Binding-    , nullEnv-    , extendEnv-    , refVar-    -- * Pattern matching-    , Match-    , MatchingTree (..)-    , MatchingState (..)-    , PatternBinding-    , LoopPatContext (..)-    , SeqPatContext (..)-    -- * Errors-    , EgisonError (..)-    , liftError-    -- * Monads-    , EgisonM (..)-    , runEgisonM-    , liftEgisonM-    , fromEgisonM-    , FreshT (..)-    , Fresh-    , MonadFresh (..)-    , runFreshT-    , MatchM-    , matchFail-    , MList (..)-    , fromList-    , fromSeq-    , fromMList-    , msingleton-    , mfoldr-    , mappend-    , mconcat-    , mmap-    , mfor-    -- * Typing-    , isBool-    , isInteger-    , isRational-    , isSymbol-    , isScalar-    , isTensor-    , isTensorWithIndex-    , isBool'-    , isInteger'-    , isRational'-    , isScalar'-    , isFloat'-    , isComplex'-    , isTensor'-    , isTensorWithIndex'-    , isChar'-    , isString'-    , isCollection'-    , isArray'-    , isHash'-    ) 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.Trans.Maybe-import           Control.Monad.Writer      (WriterT)--import qualified Data.Array                as Array-import           Data.Foldable             (foldr, 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--import           Data.List                 (intercalate)-import           Data.Text                 (Text)--import           Data.Ratio-import           System.IO--import           System.IO.Unsafe          (unsafePerformIO)+  ( isBool+  , isInteger+  , isRational+  , isSymbol+  , isScalar+  , isTensor+  , isTensorWithIndex+  , isBool'+  , isInteger'+  , isRational'+  , isScalar'+  , isFloat'+  , isComplex'+  , isTensor'+  , isTensorWithIndex'+  , isChar'+  , isString'+  , isCollection'+  , isArray'+  , isHash'+  ) where -import           Language.Egison.AST+import           Language.Egison.Data import           Language.Egison.MathExpr------- Values-----data EgisonValue =-    World-  | Char Char-  | String Text-  | Bool Bool-  | ScalarData ScalarData-  | TensorData (Tensor EgisonValue)-  | Float Double-  | 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)-  | UserMatcher Env [PatternDef]-  | Func (Maybe Var) Env [String] EgisonExpr-  | PartialFunc Env Integer EgisonExpr-  | CFunc (Maybe Var) Env String EgisonExpr-  | MemoizedFunc (Maybe Var) ObjectRef (IORef (HashMap [Integer] ObjectRef)) Env [String] EgisonExpr-  | Proc (Maybe String) Env [String] EgisonExpr-  | PatternFunc Env [String] EgisonPattern-  | PrimitiveFunc String PrimitiveFunc-  | IOFunc (EgisonM WHNFData)-  | Port Handle-  | Something-  | Undefined-  | EOF--type Matcher = EgisonValue--type PrimitiveFunc = WHNFData -> EgisonM WHNFData--data EgisonHashKey =-    IntKey Integer-  | CharKey Char-  | StrKey Text------- Scalar and Tensor Types-----data Tensor a =-    Tensor [Integer] (V.Vector a) [Index EgisonValue]-  | Scalar a- deriving (Show)--class HasTensor a where-  tensorElems :: a -> V.Vector a-  tensorSize :: a -> [Integer]-  tensorIndices :: a -> [Index EgisonValue]-  fromTensor :: Tensor a -> EgisonM a-  toTensor :: a -> EgisonM (Tensor a)-  undef :: a--instance HasTensor EgisonValue where-  tensorElems (TensorData (Tensor _ xs _)) = xs-  tensorSize (TensorData (Tensor ns _ _)) = ns-  tensorIndices (TensorData (Tensor _ _ js)) = js-  fromTensor t@Tensor{} = return $ TensorData t-  fromTensor (Scalar x) = return x-  toTensor (TensorData t) = return t-  toTensor x              = return $ Scalar x-  undef = Undefined--instance HasTensor WHNFData where-  tensorElems (Intermediate (ITensor (Tensor _ xs _))) = xs-  tensorSize (Intermediate (ITensor (Tensor ns _ _))) = ns-  tensorIndices (Intermediate (ITensor (Tensor _ _ js))) = js-  fromTensor t@Tensor{} = return $ Intermediate $ ITensor t-  fromTensor (Scalar x) = return x-  toTensor (Intermediate (ITensor t)) = return t-  toTensor x                          = return $ Scalar x-  undef = Value Undefined------- Scalars-----symbolScalarData :: String -> String -> EgisonValue-symbolScalarData id name = ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []]))--symbolScalarData' :: String -> String -> ScalarData-symbolScalarData' id name = Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []])--getSymId :: EgisonValue -> String-getSymId (ScalarData (Div (Plus [Term 1 [(Symbol id _ [], 1)]]) (Plus [Term 1 []]))) = id--getSymName :: EgisonValue -> String-getSymName (ScalarData (Div (Plus [Term 1 [(Symbol _ name [], 1)]]) (Plus [Term 1 []]))) = name--mathExprToEgison :: ScalarData -> EgisonValue-mathExprToEgison (Div p1 p2) = InductiveData "Div" [polyExprToEgison p1, polyExprToEgison p2]--polyExprToEgison :: PolyExpr -> EgisonValue-polyExprToEgison (Plus ts) = InductiveData "Plus" [Collection (Sq.fromList (map termExprToEgison ts))]--termExprToEgison :: TermExpr -> EgisonValue-termExprToEgison (Term a xs) = InductiveData "Term" [toEgison a, Collection (Sq.fromList (map symbolExprToEgison xs))]--symbolExprToEgison :: (SymbolExpr, Integer) -> EgisonValue-symbolExprToEgison (Symbol id x js, n) = Tuple [InductiveData "Symbol" [symbolScalarData id x, f js], toEgison n]- where-  f js = Collection (Sq.fromList (map (\case-                                          Superscript k -> InductiveData "Sup" [ScalarData k]-                                          Subscript k -> InductiveData "Sub" [ScalarData k]-                                          Userscript k -> InductiveData "User" [ScalarData k]-                                      ) js))-symbolExprToEgison (Apply fn mExprs, n) = Tuple [InductiveData "Apply" [ScalarData fn, Collection (Sq.fromList (map mathExprToEgison mExprs))], toEgison n]-symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n]-symbolExprToEgison (FunctionData name argnames args js, n) =-  Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData argnames)), Collection (Sq.fromList (map ScalarData args)), f js], toEgison n]- where-  f js = Collection (Sq.fromList (map (\case-                                          Superscript k -> InductiveData "Sup" [ScalarData k]-                                          Subscript k -> InductiveData "Sub" [ScalarData k]-                                          Userscript k -> InductiveData "User" [ScalarData k]-                                      ) js))--egisonToScalarData :: EgisonValue -> EgisonM ScalarData-egisonToScalarData (InductiveData "Div" [p1, p2]) = Div <$> egisonToPolyExpr p1 <*> egisonToPolyExpr p2-egisonToScalarData p1@(InductiveData "Plus" _) = Div <$> egisonToPolyExpr p1 <*> return (Plus [Term 1 []])-egisonToScalarData t1@(InductiveData "Term" _) = do-  t1' <- egisonToTermExpr t1-  return $ Div (Plus [t1']) (Plus [Term 1 []])-egisonToScalarData s1@(InductiveData "Symbol" _) = do-  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 ::Integer)])-  return $ Div (Plus [Term 1 [s1']]) (Plus [Term 1 []])-egisonToScalarData s1@(InductiveData "Apply" _) = do-  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])-  return $ Div (Plus [Term 1 [s1']]) (Plus [Term 1 []])-egisonToScalarData s1@(InductiveData "Quote" _) = do-  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])-  return $ Div (Plus [Term 1 [s1']]) (Plus [Term 1 []])-egisonToScalarData s1@(InductiveData "Function" _) = do-  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])-  return $ Div (Plus [Term 1 [s1']]) (Plus [Term 1 []])-egisonToScalarData val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack--egisonToPolyExpr :: EgisonValue -> EgisonM PolyExpr-egisonToPolyExpr (InductiveData "Plus" [Collection ts]) = Plus <$> mapM egisonToTermExpr (toList ts)-egisonToPolyExpr val = throwError =<< TypeMismatch "math poly expression" (Value val) <$> getFuncNameStack--egisonToTermExpr :: EgisonValue -> EgisonM TermExpr-egisonToTermExpr (InductiveData "Term" [n, Collection ts]) = Term <$> fromEgison n <*> mapM egisonToSymbolExpr (toList ts)-egisonToTermExpr val = throwError =<< TypeMismatch "math term expression" (Value val) <$> getFuncNameStack--egisonToSymbolExpr :: EgisonValue -> EgisonM (SymbolExpr, Integer)-egisonToSymbolExpr (Tuple [InductiveData "Symbol" [x, Collection seq], n]) = do-  let js = toList seq-  js' <- mapM (\j -> case j of-                       InductiveData "Sup" [ScalarData k] -> return (Superscript k)-                       InductiveData "Sub" [ScalarData k] -> return (Subscript k)-                       InductiveData "User" [ScalarData k] -> return (Userscript k)-                       _ -> throwError =<< TypeMismatch "math symbol expression" (Value j) <$> getFuncNameStack-               ) js-  n' <- fromEgison n-  case x of-    (ScalarData (Div (Plus [Term 1 [(Symbol id name [], 1)]]) (Plus [Term 1 []]))) ->-      return (Symbol id name js', n')-egisonToSymbolExpr (Tuple [InductiveData "Apply" [fn, Collection mExprs], n]) = do-  fn' <- extractScalar fn-  mExprs' <- mapM egisonToScalarData (toList mExprs)-  n' <- fromEgison n-  return (Apply fn' mExprs', n')-egisonToSymbolExpr (Tuple [InductiveData "Quote" [mExpr], n]) = do-  mExpr' <- egisonToScalarData mExpr-  n' <- fromEgison n-  return (Quote mExpr', n')-egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection argnames, Collection args, Collection seq], n]) = do-  name' <- extractScalar name-  argnames' <- mapM extractScalar (toList argnames)-  args' <- mapM extractScalar (toList args)-  let js = toList seq-  js' <- mapM (\j -> case j of-                         InductiveData "Sup" [ScalarData k] -> return (Superscript k)-                         InductiveData "Sub" [ScalarData k] -> return (Subscript k)-                         InductiveData "User" [ScalarData k] -> return (Userscript k)-                         _ -> throwError =<< TypeMismatch "math symbol expression" (Value j) <$> getFuncNameStack-               ) js-  n' <- fromEgison n-  return (FunctionData name' argnames' args' js', n')-egisonToSymbolExpr val = throwError =<< TypeMismatch "math symbol expression" (Value val) <$> getFuncNameStack------- ExtractScalar-----extractScalar :: EgisonValue -> EgisonM ScalarData-extractScalar (ScalarData mExpr) = return mExpr-extractScalar val = throwError =<< TypeMismatch "math expression" (Value val) <$> getFuncNameStack--extractScalar' :: WHNFData -> EgisonM ScalarData-extractScalar' (Value (ScalarData x)) = return x-extractScalar' val = throwError =<< TypeMismatch "integer or string" val <$> getFuncNameStack------------instance Show EgisonValue where-  show (Char c) = '\'' : c : "'"-  show (String str) = show str-  show (Bool True) = "True"-  show (Bool False) = "False"-  show (ScalarData mExpr) = show mExpr-  show (TensorData (Tensor [_] xs js)) = "[| " ++ intercalate ", " (map show (V.toList xs)) ++ " |]" ++ concatMap show js-  show (TensorData (Tensor [0, 0] _ js)) = "[| [|  |] |]" ++ concatMap show js-  show (TensorData (Tensor [_, j] xs js)) = "[| " ++ intercalate ", " (f (fromIntegral j) (V.toList xs)) ++ " |]" ++ concatMap show js-    where-      f _ [] = []-      f j xs = ["[| " ++ intercalate ", " (map show (take j xs)) ++ " |]"] ++ f j (drop j xs)-  show (TensorData (Tensor ns xs js)) = "(tensor [" ++ intercalate ", " (map show ns) ++ "] [" ++ intercalate ", " (map show (V.toList xs)) ++ "] )" ++ concatMap show js-  show (Float x) = show x-  show (InductiveData name vals) = name ++ concatMap ((' ':) . show') vals-    where-      show' x | isAtomic x = show x-              | 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) ++ "|}"-  show UserMatcher{} = "#<user-matcher>"-  show (Func Nothing _ args _) = "(lambda [" ++ intercalate ", " (map show args) ++ "] ...)"-  show (Func (Just name) _ _ _) = show name-  show (PartialFunc _ n expr) = show n ++ "#" ++ show expr-  show (CFunc Nothing _ name _) = "(cambda " ++ name ++ " ...)"-  show (CFunc (Just name) _ _ _) = show name-  show (MemoizedFunc Nothing _ _ _ names _) = "(memoized-lambda [" ++ intercalate ", " names ++ "] ...)"-  show (MemoizedFunc (Just name) _ _ _ _ _) = show name-  show (Proc Nothing _ names _) = "(procedure [" ++ intercalate ", " names ++ "] ...)"-  show (Proc (Just name) _ _ _) = name-  show PatternFunc{} = "#<pattern-function>"-  show (PrimitiveFunc name _) = "#<primitive-function " ++ name ++ ">"-  show (IOFunc _) = "#<io-function>"-  show (Port _) = "#<port>"-  show Something = "something"-  show Undefined = "undefined"-  show World = "#<world>"-  show EOF = "#<eof>"---- False if we have to put parenthesis around it to make it an atomic expression.-isAtomic :: EgisonValue -> Bool-isAtomic (InductiveData _ []) = True-isAtomic (InductiveData _ _)  = False-isAtomic (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = True-isAtomic (ScalarData _) = False-isAtomic _ = True--instance Eq EgisonValue where- (Char c) == (Char c') = c == c'- (String str) == (String str') = str == str'- (Bool b) == (Bool b') = b == b'- (ScalarData x) == (ScalarData y) = x == y- (TensorData (Tensor js xs _)) == (TensorData (Tensor js' xs' _)) = (js == js') && (xs == xs')- (Float x) == (Float x') = x == x'- (InductiveData name vals) == (InductiveData name' vals') = (name == name') && (vals == vals')- (Tuple vals) == (Tuple vals') = vals == vals'- (Collection vals) == (Collection vals') = vals == vals'- (Array vals) == (Array vals') = vals == vals'- (IntHash vals) == (IntHash vals') = vals == vals'- (CharHash vals) == (CharHash vals') = vals == vals'- (StrHash vals) == (StrHash vals') = vals == vals'- (PrimitiveFunc name1 _) == (PrimitiveFunc name2 _) = name1 == name2- -- Temporary: searching a better solution- (Func Nothing _ xs1 expr1) == (Func Nothing _ xs2 expr2) = (xs1 == xs2) && (expr1 == expr2)- (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _) = name1 == name2- (CFunc Nothing _ x1 expr1) == (CFunc Nothing _ x2 expr2) = (x1 == x2) && (expr1 == expr2)- (CFunc (Just name1) _ _ _) == (CFunc (Just name2) _ _ _) = name1 == name2- _ == _ = False------- Egison data and Haskell data----class EgisonData a where-  toEgison :: a -> EgisonValue-  fromEgison :: EgisonValue -> EgisonM a--instance EgisonData Char where-  toEgison = Char-  fromEgison (Char c) = return c-  fromEgison val      = throwError =<< TypeMismatch "char" (Value val) <$> getFuncNameStack--instance EgisonData Text where-  toEgison = String-  fromEgison (String str) = return str-  fromEgison val          = throwError =<< TypeMismatch "string" (Value val) <$> getFuncNameStack--instance EgisonData Bool where-  toEgison = Bool-  fromEgison (Bool b) = return b-  fromEgison val      = throwError =<< TypeMismatch "bool" (Value val) <$> getFuncNameStack--instance EgisonData Integer where-  toEgison 0 = ScalarData $ mathNormalize' (Div (Plus []) (Plus [Term 1 []]))-  toEgison i = ScalarData $ mathNormalize' (Div (Plus [Term i []]) (Plus [Term 1 []]))-  fromEgison (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = return 0-  fromEgison (ScalarData (Div (Plus [Term x []]) (Plus [Term 1 []]))) = return x-  fromEgison val = throwError =<< TypeMismatch "integer" (Value val) <$> getFuncNameStack--instance EgisonData Rational where-  toEgison r = ScalarData $ mathNormalize' (Div (Plus [Term (numerator r) []]) (Plus [Term (denominator r) []]))-  fromEgison (ScalarData (Div (Plus []) _)) = return 0-  fromEgison (ScalarData (Div (Plus [Term x []]) (Plus [Term y []]))) = return (x % y)-  fromEgison val = throwError =<< TypeMismatch "rational" (Value val) <$> getFuncNameStack--instance EgisonData Double where-  toEgison f = Float f-  fromEgison (Float f) = return f-  fromEgison val       = throwError =<< TypeMismatch "float" (Value val) <$> getFuncNameStack--instance EgisonData Handle where-  toEgison = Port-  fromEgison (Port h) = return h-  fromEgison val      = throwError =<< TypeMismatch "port" (Value val) <$> getFuncNameStack--instance EgisonData a => EgisonData [a] where-  toEgison xs = Collection $ Sq.fromList (map toEgison xs)-  fromEgison (Collection seq) = mapM fromEgison (toList seq)-  fromEgison val = throwError =<< TypeMismatch "collection" (Value val) <$> getFuncNameStack--instance EgisonData () where-  toEgison () = Tuple []-  fromEgison (Tuple []) = return ()-  fromEgison val = throwError =<< TypeMismatch "zero element tuple" (Value val) <$> getFuncNameStack--instance (EgisonData a, EgisonData b) => EgisonData (a, b) where-  toEgison (x, y) = Tuple [toEgison x, toEgison y]-  fromEgison (Tuple [x, y]) = liftM2 (,) (fromEgison x) (fromEgison y)-  fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack--instance (EgisonData a, EgisonData b, EgisonData c) => EgisonData (a, b, c) where-  toEgison (x, y, z) = Tuple [toEgison x, toEgison y, toEgison z]-  fromEgison (Tuple [x, y, z]) = do-    x' <- fromEgison x-    y' <- fromEgison y-    z' <- fromEgison z-    return (x', y', z')-  fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack--instance (EgisonData a, EgisonData b, EgisonData c, EgisonData d) => EgisonData (a, b, c, d) where-  toEgison (x, y, z, w) = Tuple [toEgison x, toEgison y, toEgison z, toEgison w]-  fromEgison (Tuple [x, y, z, w]) = do-    x' <- fromEgison x-    y' <- fromEgison y-    z' <- fromEgison z-    w' <- fromEgison w-    return (x', y', z', w')-  fromEgison val = throwError =<< TypeMismatch "two elements tuple" (Value val) <$> getFuncNameStack------- Internal Data------- |For memoization-type ObjectRef = IORef Object--data Object =-    Thunk (EgisonM WHNFData)-  | WHNF WHNFData--data WHNFData =-    Intermediate Intermediate-  | Value EgisonValue--data Intermediate =-    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)-  | ITensor (Tensor WHNFData)--data Inner =-    IElement ObjectRef-  | ISubCollection ObjectRef--instance Show WHNFData where-  show (Value val) = show val-  show (Intermediate (IInductiveData name _)) = "<" ++ name ++ " ...>"-  show (Intermediate (ITuple _)) = "[...]"-  show (Intermediate (ICollection _)) = "{...}"-  show (Intermediate (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) ++ "|]"--instance Show Object where-  show (Thunk _)   = "#<thunk>"-  show (WHNF whnf) = show whnf--instance Show ObjectRef where-  show _ = "#<ref>"------- Extract data from WHNF----class EgisonData a => EgisonWHNF a where-  toWHNF :: a -> WHNFData-  fromWHNF :: WHNFData -> EgisonM a-  toWHNF = Value . toEgison--instance EgisonWHNF Char where-  fromWHNF (Value (Char c)) = return c-  fromWHNF whnf             = throwError =<< TypeMismatch "char" whnf <$> getFuncNameStack--instance EgisonWHNF Text where-  fromWHNF (Value (String str)) = return str-  fromWHNF whnf                 = throwError =<< TypeMismatch "string" whnf <$> getFuncNameStack--instance EgisonWHNF Bool where-  fromWHNF (Value (Bool b)) = return b-  fromWHNF whnf             = throwError =<< TypeMismatch "bool" whnf <$> getFuncNameStack--instance EgisonWHNF Integer where-  fromWHNF (Value (ScalarData (Div (Plus []) (Plus [Term 1 []])))) = return 0-  fromWHNF (Value (ScalarData (Div (Plus [Term x []]) (Plus [Term 1 []])))) = return x-  fromWHNF whnf = throwError =<< TypeMismatch "integer" whnf <$> getFuncNameStack--instance EgisonWHNF Double where-  fromWHNF (Value (Float f)) = return f-  fromWHNF whnf              = throwError =<< TypeMismatch "float" whnf <$> getFuncNameStack--instance EgisonWHNF Handle where-  fromWHNF (Value (Port h)) = return h-  fromWHNF whnf             = throwError =<< TypeMismatch "port" whnf <$> getFuncNameStack------- Environment-----data Env = Env [HashMap Var ObjectRef] (Maybe VarWithIndices)- deriving (Show)--type Binding = (Var, ObjectRef)--instance Show (Index EgisonValue) where-  show (Superscript i) = case i of-    ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "~[" ++ show i ++ "]"-    _ -> "~" ++ show i-  show (Subscript i) = case i of-    ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"-    _ -> "_" ++ show i-  show (SupSubscript i) = "~_" ++ show i-  show (DFscript i j) = "_d" ++ show i ++ show j-  show (Userscript i) = case i of-    ScalarData (Div (Plus [Term 1 [(Symbol _ _ (_:_), 1)]]) (Plus [Term 1 []])) -> "_[" ++ show i ++ "]"-    _ -> "|" ++ show i--nullEnv :: Env-nullEnv = Env [] Nothing--extendEnv :: Env -> [Binding] -> Env-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------- Pattern Match-----type Match = [Binding]--data MatchingState-  = MState { mStateEnv      :: Env-           , loopPatCtx     :: [LoopPatContext]-           , seqPatCtx      :: [SeqPatContext]-           , mStateBindings :: [Binding]-           , mTrees         :: [MatchingTree]-           }--instance Show MatchingState where-  show ms = "(MState " ++ unwords ["_", "_", "_", show (mStateBindings ms), show (mTrees ms)] ++ ")"--data MatchingTree =-    MAtom EgisonPattern WHNFData Matcher-  | MNode [PatternBinding] MatchingState- deriving (Show)--type PatternBinding = (String, EgisonPattern)--data LoopPatContext = LoopPatContext Binding ObjectRef EgisonPattern EgisonPattern EgisonPattern- deriving (Show)--data SeqPatContext = SeqPatContext [MatchingTree] EgisonPattern [Matcher] [WHNFData]- deriving (Show)------- Errors-----type CallStack = [String]--data EgisonError =-    UnboundVariable String CallStack-  | TypeMismatch String WHNFData CallStack-  | ArgumentsNumWithNames [String] Int Int CallStack-  | ArgumentsNumPrimitive Int Int CallStack-  | TupleLength Int Int CallStack-  | InconsistentTensorSize CallStack-  | InconsistentTensorIndex CallStack-  | TensorIndexOutOfBounds Integer Integer CallStack-  | NotImplemented String CallStack-  | Assertion String CallStack-  | Parser String-  | EgisonBug String CallStack-  | MatchFailure String CallStack-  | Default String-  deriving Typeable--instance Show EgisonError where-  show (UnboundVariable var stack) =-    "Unbound variable: " ++ show var ++ showTrace stack-  show (TypeMismatch expected found stack) =-    "Expected " ++  expected ++ ", but found: " ++ show found ++ showTrace stack-  show (ArgumentsNumWithNames names expected got stack) =-    "Wrong number of arguments: " ++ show names ++ ": expected " ++ show expected ++ ", but got " ++  show got ++ showTrace stack-  show (ArgumentsNumPrimitive expected got stack) =-    "Wrong number of arguments for a primitive function: expected " ++ show expected ++ ", but got " ++  show got ++ showTrace stack-  show (TupleLength expected got stack) =-    "Inconsistent tuple lengths: expected " ++ show expected ++ ", but got " ++  show got ++ showTrace stack-  show (InconsistentTensorSize stack) = "Inconsistent tensor size" ++ showTrace stack-  show (InconsistentTensorIndex stack) = "Inconsistent tensor index" ++ showTrace stack-  show (TensorIndexOutOfBounds m n stack) = "Tensor index out of bounds: " ++ show m ++ ", " ++ show n ++ showTrace stack-  show (NotImplemented message stack) = "Not implemented: " ++ message ++ showTrace stack-  show (Assertion message stack) = "Assertion failed: " ++ message ++ showTrace stack-  show (Parser err) = "Parse error at: " ++ err-  show (EgisonBug message stack) = "Egison Error: " ++ message ++ showTrace stack-  show (MatchFailure currentFunc stack) = "Failed pattern match in: " ++ currentFunc ++ showTrace stack-  show (Default message) = "Error: " ++ message--showTrace :: CallStack -> String-showTrace stack = "\n  stack trace: " ++ intercalate ", " stack--instance Exception EgisonError--liftError :: (MonadError e m) => Either e a -> m a-liftError = either throwError return------- Monads-----newtype EgisonM a = EgisonM {-    unEgisonM :: ExceptT EgisonError (FreshT IO) a-  } deriving (Functor, Applicative, Monad, MonadIO, MonadError EgisonError, MonadFresh)--instance MonadFail EgisonM where-    fail msg = throwError =<< EgisonBug msg <$> getFuncNameStack--runEgisonM :: EgisonM a -> FreshT IO (Either EgisonError a)-runEgisonM = runExceptT . unEgisonM--liftEgisonM :: Fresh (Either EgisonError a) -> EgisonM a-liftEgisonM m = EgisonM $ ExceptT $ FreshT $ do-  s <- get-  (a, s') <- return $ runFresh s m-  put s'-  return $ either throwError return a--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  -- -- Typing

@@ -1,6 +1,5 @@ {- | Module      : Language.Egison.Util-Copyright   : Satoshi Egi Licence     : MIT  This module provides utility functions.

@@ -25,9 +25,11 @@   toNonS x              = x  instance SyntaxElement EgisonExpr where-  toNonS (IntegerExpr x)-    | x < 0     = UnaryOpExpr "-" (IntegerExpr (-x))-    | otherwise = IntegerExpr x+  toNonS (IntegerExpr x) = IntegerExpr x+  toNonS (VarExpr v) | any (\op -> func op == prettyS v) reservedExprInfix =+    SectionExpr op Nothing Nothing+      where+        op = fromJust $ find (\op -> func op == prettyS v) reservedExprInfix   toNonS (VarExpr x) = VarExpr (toNonS x)    toNonS (IndexedExpr b x ys)  = IndexedExpr  b (toNonS x) (map toNonS ys)@@ -35,19 +37,32 @@   toNonS (SuprefsExpr b x y)   = SuprefsExpr  b (toNonS x) (toNonS y)   toNonS (UserrefsExpr b x y)  = UserrefsExpr b (toNonS x) (toNonS y)   toNonS (PowerExpr x y) = BinaryOpExpr powerOp (toNonS x) (toNonS y)-    where powerOp = fromJust $ find (\op -> repr op == "^") reservedBinops+    where powerOp = fromJust $ find (\op -> repr op == "^") reservedExprInfix   toNonS (InductiveDataExpr x ys) = InductiveDataExpr x (map toNonS ys)   toNonS (TupleExpr xs)      = TupleExpr (map toNonS xs)-  toNonS (CollectionExpr xs) = CollectionExpr (map toNonS xs)+  toNonS (CollectionExpr xs)+    | all isElementExpr xs = CollectionExpr (map toNonS xs)+    | otherwise            = f xs+    where+      isElementExpr :: InnerExpr -> Bool+      isElementExpr ElementExpr{} = True+      isElementExpr _             = False+      f [] = CollectionExpr []+      f [ElementExpr x] = CollectionExpr [ElementExpr (toNonS x)]+      f [SubCollectionExpr x] = toNonS x+      f (ElementExpr x : xs) = BinaryOpExpr cons (toNonS x) (f xs)+      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) -  toNonS (LambdaExpr xs y)          = LambdaExpr xs (toNonS y)-  toNonS (MemoizedLambdaExpr xs y)  = MemoizedLambdaExpr xs (toNonS y)-  toNonS (CambdaExpr _ _)           = error "Not supported"-  toNonS (ProcedureExpr xs y)       = ProcedureExpr xs (toNonS y)-  -- PatternFunctionExpr+  toNonS (LambdaExpr xs e)          = LambdaExpr xs (toNonS e)+  toNonS (MemoizedLambdaExpr xs e)  = MemoizedLambdaExpr xs (toNonS e)+  toNonS (CambdaExpr x e)           = CambdaExpr x (toNonS e)+  toNonS (ProcedureExpr xs e)       = ProcedureExpr xs (toNonS e)+  toNonS (PatternFunctionExpr xs p) = PatternFunctionExpr xs (toNonS p)    toNonS (IfExpr x y z)         = IfExpr (toNonS x) (toNonS y) (toNonS z)   toNonS (LetRecExpr xs y)      = LetRecExpr (map toNonS xs) (toNonS y)@@ -55,10 +70,10 @@   toNonS (LetStarExpr xs y)     = LetRecExpr (map toNonS xs) (toNonS y)   toNonS (WithSymbolsExpr xs y) = WithSymbolsExpr xs (toNonS y) -  toNonS (MatchExpr pmmode x y zs)    = MatchExpr pmmode (toNonS x) (toNonS y) (map toNonS zs)-  toNonS (MatchAllExpr pmmode x y zs) = MatchAllExpr pmmode (toNonS x) (toNonS y) (map toNonS zs)-  toNonS (MatchLambdaExpr x ys)       = MatchLambdaExpr    (toNonS x) (map toNonS ys)-  toNonS (MatchAllLambdaExpr x ys)    = MatchAllLambdaExpr (toNonS x) (map toNonS ys)+  toNonS (MatchExpr pmmode m p xs)    = MatchExpr pmmode (toNonS m) (toNonS p) (map toNonS xs)+  toNonS (MatchAllExpr pmmode m p xs) = MatchAllExpr pmmode (toNonS m) (toNonS p) (map toNonS xs)+  toNonS (MatchLambdaExpr p xs)       = MatchLambdaExpr    (toNonS p) (map toNonS xs)+  toNonS (MatchAllLambdaExpr p xs)    = MatchAllLambdaExpr (toNonS p) (map toNonS xs)    toNonS (MatcherExpr xs) = MatcherExpr (map toNonS xs) @@ -69,28 +84,79 @@   toNonS (DoExpr xs y) = DoExpr (map toNonS xs) (toNonS y)   toNonS (IoExpr x)    = IoExpr (toNonS x) -  toNonS (ApplyExpr (VarExpr (Var [f] [])) (TupleExpr (y:ys)))-    | any (\op -> func op == f) reservedBinops =-      foldl (\acc x -> BinaryOpExpr op acc (toNonS x)) (toNonS y) ys+  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       where-        op = fromJust $ find (\op -> func op == f) reservedBinops+        op = fromJust $ find (\op -> func op == prettyS f) reservedExprInfix++        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 (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+      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 (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)+  toNonS (FlipIndicesExpr _) = error "Not supported: FlipIndicesExpr"+   toNonS x = x +instance SyntaxElement EgisonPattern where+  toNonS (ValuePat e) = ValuePat (toNonS e)+  toNonS (PredPat e) = PredPat (toNonS e)+  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 (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 (TuplePat ps) = TuplePat (map toNonS ps)+  toNonS (InductivePat name [p1, p2])+    | any (\op -> func op == name) reservedPatternInfix =+      InfixPat op (toNonS p1) (toNonS p2)+        where op = fromJust $ find (\op -> func op == name) reservedPatternInfix+  toNonS (InductivePat name ps) = InductivePat name (map toNonS ps)+  toNonS (LoopPat i range p1 p2) = LoopPat i (toNonS range) (toNonS p1) (toNonS p2)+  toNonS (PApplyPat e p) = PApplyPat (toNonS e) (map toNonS p)+  toNonS (SeqConsPat p1 p2) = SeqConsPat (toNonS p1) (toNonS p2)+  toNonS p = p++instance SyntaxElement LoopRange where+  toNonS (LoopRange e1 e2 p) = LoopRange (toNonS e1) (toNonS e2) (toNonS p)+ instance SyntaxElement a => SyntaxElement (Index a) where   toNonS script = toNonS <$> script  instance SyntaxElement InnerExpr where   toNonS (ElementExpr x) = ElementExpr (toNonS x)---  toNonS (SubCollectionExpr _) = error "Not supported"-  toNonS (SubCollectionExpr _) = ElementExpr UndefinedExpr+  toNonS (SubCollectionExpr _) = error "Not supported: SubCollectionExpr"  instance SyntaxElement BindingExpr where   toNonS (vars, x) = (map toNonS vars, toNonS x)  instance SyntaxElement MatchClause where-  toNonS (x, y) = (x, toNonS y)+  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)@@ -99,10 +165,12 @@   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+         in concat $ heads : map (\(x:xs) -> toUpper x : xs) tails + main :: IO () main = do   args <- getArgs@@ -110,7 +178,12 @@   -- 'ast' is not desugared   let ast = parseTopExprs input   case ast of-    Left _ -> return ()+    Left err ->+      print err     Right ast -> do+      putStrLn "--"+      putStrLn "-- This file has been auto-generated by egison-translator."+      putStrLn "--"+      putStrLn ""       putDoc $ prettyTopExprs $ map toNonS ast       putStrLn ""

@@ -28,10 +28,14 @@  (define $snd 2#%2) +(define $apply+  (lambda [$f $x]+    (f x)))+ (define $b.compose   (lambda [$f $g]     (lambda $x-      (apply g (apply f x)))))+      (g (f x)))))  (define $compose   (cambda $fs

@@ -45,12 +45,12 @@        [<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] (ref xa i)) (between 1 n))+                  [(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] (ref xa i)) (between 1 n))+                  [(map (lambda [$i] xa_i) (between 1 n))                    rs]])]}]        [<cons $ $> [a (sorted-list a)]         {[{$x @$xs} {[x xs]}]

@@ -1,9 +1,24 @@+(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)

@@ -23,7 +23,7 @@ (define $M.power   (lambda [%m $n]     (repeated-squaring M.* m n)))-                       + (define $M.comm   (lambda [%m1 %m2]     (with-symbols {i j k}@@ -38,20 +38,20 @@               (if (even? (+ %1 %2))                 (/ (M.det (M.join A B C D)) d)                 (* -1 (/ (M.det (M.join A B C D)) d)))]})-        (tensor-size m)))))+        (tensor-shape m)))))  (define $trace (lambda [%t] (with-symbols {i} (contract + t~i_i))))  (define $matrix   (matcher     {[<quad-cons $ $ $ $> [math-expr matrix matrix matrix]-      {[$tgt (match (tensor-size tgt) (list integer)+      {[$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-size tgt)]+        (let* {[$ns (tensor-shape tgt)]                [$m (nth 1 ns)]                [$n (nth 2 ns)]}           {[tgt_i_j@@ -68,13 +68,13 @@  (define $M.join   (lambda [%A %B %C %D]-    (let* {[$as (tensor-size A)]+    (let* {[$as (tensor-shape A)]            [$a1 (nth 1 as)] [$a2 (nth 2 as)]-           [$bs (tensor-size B)]+           [$bs (tensor-shape B)]            [$b1 (nth 1 bs)] [$b2 (nth 2 bs)]-           [$cs (tensor-size C)]+           [$cs (tensor-shape C)]            [$c1 (nth 1 cs)] [$c2 (nth 2 cs)]-           [$ds (tensor-size D)]+           [$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})]@@ -130,7 +130,7 @@  (define $M.determinant   (lambda [%m]-    (match (tensor-size m) (list integer)+    (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)]}@@ -154,7 +154,7 @@  (define $M.eigenvalues   (lambda [%m]-    (match (tensor-size m) (list integer)+    (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})]@@ -162,7 +162,7 @@  (define $M.eigenvectors   (lambda [%m]-    (match (tensor-size m) (list integer)+    (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)]@@ -176,7 +176,7 @@  (define $M.LU   (lambda [%x]-    (match (tensor-size x) (list integer)+    (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})]

@@ -6,7 +6,7 @@  (define $tensor-order   (lambda [%A]-    (length (tensor-size A))))+    (length (tensor-shape A))))  (define $unit-tensor   (lambda [$ns]@@ -33,11 +33,11 @@  (define $T.+   (lambda [%t1 %t2]-    (tensor (tensor-size t1)+    (tensor (tensor-shape t1)             (map2 + (tensor-to-list t1) (tensor-to-list t2)))))   (define $T.-   (lambda [%t1 %t2]-    (tensor (tensor-size t1)+    (tensor (tensor-shape t1)             (map2 - (tensor-to-list t1) (tensor-to-list t2)))))

@@ -70,7 +70,7 @@ (define $multivariate-taylor-expansion   (lambda [%f %xs %as]     (with-symbols {h}-      (let {[$hs (generate-tensor 1#h_%1 (tensor-size xs))]}+      (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)

@@ -4,7 +4,7 @@ ;;;;; ;;;;; -(define $to-math-expr (lambda [$arg] (math-normalize1 (apply to-math-expr' arg))))+(define $to-math-expr (lambda [$arg] (math-normalize1 (to-math-expr' arg))))  (define $+' (cambda $xs (foldl b.+ (car xs) (cdr xs)))) (define $-' (cambda $xs (foldl b.- (car xs) (cdr xs))))

@@ -0,0 +1,32 @@+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 |] |]~#_#

@@ -0,0 +1,37 @@+-- 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))))

@@ -0,0 +1,331 @@+--+-- 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]

@@ -0,0 +1,118 @@+--+-- 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

@@ -0,0 +1,69 @@+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'

@@ -0,0 +1,21 @@+--+-- 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

@@ -0,0 +1,37 @@+--+-- 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])

@@ -0,0 +1,22 @@+--+-- 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)

@@ -0,0 +1,73 @@+--+-- 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 |] |]"

@@ -108,6 +108,8 @@ 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@@ -119,6 +121,21 @@ 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@@ -153,6 +170,13 @@   (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@@ -169,6 +193,10 @@   (A 2)   1 +assertEqual "capply"+  (capply (+) [1, 2])+  3+ {-   This is a comment  -}@@ -252,9 +280,9 @@    | #2 :: _ | #1 :: _ -> True)  assert "not pattern"-  (match 1 as integer with-   | ! #1 -> False-   | ! #2 -> True)+  (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@@ -330,29 +358,29 @@    | ($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 "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 & $x) :: (repeat x) in---    match [1, 1, 1, 1] as list integer with---    | repeat $n -> n)---   1+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 "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@@ -413,6 +441,31 @@    -> 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 --@@ -433,9 +486,9 @@   ([| 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 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)@@ -552,3 +605,24 @@ 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

@@ -86,7 +86,7 @@ (define $taylor-expansion   (lambda [%f %xs %as]     (with-symbols {h}-      (let {[$hs (generate-tensor 1#h_%1 (tensor-size xs))]}+      (let {[$hs (generate-tensor 1#h_%1 (tensor-shape xs))]}         (map2 *               (map 1#(/ 1 (fact %1)) nats0)               (map (compose (V.substitute xs as $)

@@ -0,0 +1,155 @@+(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

@@ -0,0 +1,147 @@+(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))))++(define $unit-propagate+  (lambda [$stage $cnf $trail]+    (unit-propagate' stage cnf trail trail)))++(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)]})))++(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]]})))++(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')]})))++(define $backjump+  (lambda [$stage $trail]+    (match-dfs trail (list assignment)+      {[<join _ (& <cons <guessed [_ ,stage]> _> $trail')> trail']+       [_ 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)]})))++(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 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'}))]}))))++(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

@@ -0,0 +1,41 @@+(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 $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))})]})))++(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

@@ -0,0 +1,43 @@+(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

@@ -0,0 +1,53 @@+(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

@@ -0,0 +1,363 @@+(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

@@ -33,15 +33,7 @@ testCases =   [ "test/syntax.egi"   , "test/primitive.egi"-  , "test/lib/math/analysis.egi"   , "test/lib/math/tensor.egi"-  , "test/lib/math/arithmetic.egi"-  , "test/lib/math/algebra.egi"-  , "test/lib/core/string.egi"-  , "test/lib/core/base.egi"-  , "test/lib/core/collection.egi"-  , "test/lib/core/order.egi"-  , "test/lib/core/number.egi"    , "sample/poker-hands.egi"   , "sample/poker-hands-with-joker.egi"@@ -60,7 +52,13 @@   [ "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

@@ -66,6 +66,16 @@     {[<nioj ,{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}})++(assert-equal "sorted-list - join-cons 2"+  (match-all {3 1 2 4} (sorted-list integer)+    {[<join _ <cons ,2 $xs>> xs]})+  {})+ ;;; ;;; Multiset Pattern-Matching ;;;