egison 5.0.0 → 5.1.0

raw patch · 178 files changed

+18730/−8342 lines, 178 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Changelog.md +51/−0
• egison.cabal +14/−4
• hs-src/Interpreter/egison.hs +5/−5
• hs-src/Language/Egison.hs +5/−3
• hs-src/Language/Egison/AST.hs +102/−10
• hs-src/Language/Egison/CmdOptions.hs +8/−4
• hs-src/Language/Egison/Core.hs +414/−187
• hs-src/Language/Egison/Data.hs +82/−193
• hs-src/Language/Egison/Data/Utils.hs +28/−9
• hs-src/Language/Egison/Desugar.hs +678/−42
• hs-src/Language/Egison/EnvBuilder.hs +411/−142
• hs-src/Language/Egison/Eval.hs +364/−285
• hs-src/Language/Egison/EvalState.hs +180/−3
• hs-src/Language/Egison/IExpr.hs +117/−6
• hs-src/Language/Egison/Math.hs +58/−22
• hs-src/Language/Egison/Math/Arith.hs +0/−51
• hs-src/Language/Egison/Math/CAS.hs +1477/−0
• hs-src/Language/Egison/Math/Expr.hs +0/−360
• hs-src/Language/Egison/Math/Normalize.hs +0/−128
• hs-src/Language/Egison/Math/Rewrite.hs +343/−230
• hs-src/Language/Egison/MathOutput.hs +8/−8
• hs-src/Language/Egison/Parser/NonS.hs +480/−50
• hs-src/Language/Egison/Pretty.hs +66/−7
• hs-src/Language/Egison/PrettyMath/AST.hs +103/−101
• hs-src/Language/Egison/PrettyMath/AsciiMath.hs +39/−39
• hs-src/Language/Egison/PrettyMath/Latex.hs +69/−57
• hs-src/Language/Egison/PrettyMath/Mathematica.hs +47/−47
• hs-src/Language/Egison/PrettyMath/Maxima.hs +38/−38
• hs-src/Language/Egison/Primitives.hs +806/−20
• hs-src/Language/Egison/Primitives/Arith.hs +47/−34
• hs-src/Language/Egison/Primitives/Types.hs +42/−12
• hs-src/Language/Egison/Tensor.hs +45/−12
• hs-src/Language/Egison/Type/Check.hs +57/−7
• hs-src/Language/Egison/Type/Env.hs +9/−31
• hs-src/Language/Egison/Type/Error.hs +158/−3
• hs-src/Language/Egison/Type/Infer.hs +4243/−3242
• hs-src/Language/Egison/Type/Instance.hs +114/−12
• hs-src/Language/Egison/Type/Pretty.hs +48/−14
• hs-src/Language/Egison/Type/RuntimeType.hs +108/−0
• hs-src/Language/Egison/Type/Subst.hs +18/−3
• hs-src/Language/Egison/Type/Subtype.hs +281/−0
• hs-src/Language/Egison/Type/Tensor.hs +2/−1
• hs-src/Language/Egison/Type/TensorMapInsertion.hs +328/−117
• hs-src/Language/Egison/Type/TypeClassExpand.hs +1725/−1367
• hs-src/Language/Egison/Type/TypedDesugar.hs +54/−15
• hs-src/Language/Egison/Type/Types.hs +309/−31
• hs-src/Language/Egison/Type/Unify.hs +478/−430
• lib/core/assoc.egi +9/−7
• lib/core/base.egi +154/−22
• lib/core/collection.egi +31/−31
• lib/core/deprecated.egi +3/−3
• lib/core/maybe.egi +1/−1
• lib/core/order.egi +0/−3
• lib/core/random.egi +2/−2
• lib/math/algebra/equations.egi +13/−13
• lib/math/algebra/groebner.egi +465/−0
• lib/math/algebra/inverse.egi +4/−4
• lib/math/algebra/matrix.egi +64/−12
• lib/math/algebra/root.egi +68/−20
• lib/math/algebra/tensor.egi +43/−5
• lib/math/algebra/vector.egi +11/−11
• lib/math/analysis/derivative.egi +128/−49
• lib/math/analysis/integral.egi +4/−4
• lib/math/common/arithmetic.egi +33/−22
• lib/math/common/constants.egi +1/−1
• lib/math/common/functions.egi +40/−27
• lib/math/common/interval.egi +141/−0
• lib/math/expression.egi +365/−166
• lib/math/geometry/3d-euclidean-space.egi +2/−2
• lib/math/geometry/4d-euclidean-space.egi +2/−2
• lib/math/geometry/differential-form.egi +7/−7
• lib/math/geometry/minkowski-space.egi +2/−2
• lib/math/no-normalize.egi +1/−1
• lib/math/normalize.egi +135/−30
• sample/STATUS.md +476/−0
• sample/bipartite-graph.egi +5/−2
• sample/chopsticks.egi +1/−1
• sample/five-color.egi +2/−2
• sample/generalized-sequential-pattern-mining.egi +2/−2
• sample/graph.egi +2/−2
• sample/mahjong.egi +12/−10
• sample/math/algebra/canonical-form-absorption.egi +44/−0
• sample/math/algebra/cubic-equation.egi +6/−6
• sample/math/algebra/groebner-basis.egi +106/−0
• sample/math/algebra/quadratic-equation.egi +5/−5
• sample/math/algebra/quartic-equation.egi +5/−5
• sample/math/analysis/eulers-formula.egi +1/−1
• sample/math/analysis/leibniz-formula.egi +5/−5
• sample/math/analysis/vector-analysis.egi +27/−4
• sample/math/geometry/chern-form-of-CP1.egi +6/−3
• sample/math/geometry/chern-form-of-CP2.egi +2/−2
• sample/math/geometry/curvature-form.egi +10/−10
• sample/math/geometry/euler-form-of-S2.egi +27/−27
• sample/math/geometry/euler-form-of-T2.egi +42/−25
• sample/math/geometry/exterior-derivative.egi +15/−7
• sample/math/geometry/hodge-E3.egi +2/−2
• sample/math/geometry/hodge-Minkowski.egi +9/−9
• sample/math/geometry/hodge-laplacian-polar.egi +16/−13
• sample/math/geometry/hodge-laplacian-spherical.egi +9/−9
• sample/math/geometry/kahler-geometry-of-CP1.egi +85/−0
• sample/math/geometry/polar-laplacian-2d-2.egi +22/−13
• sample/math/geometry/polar-laplacian-2d-3.egi +9/−9
• sample/math/geometry/polar-laplacian-2d.egi +18/−12
• sample/math/geometry/polar-laplacian-3d-2.egi +2/−2
• sample/math/geometry/polar-laplacian-3d-3.egi +2/−2
• sample/math/geometry/polar-laplacian-3d.egi +7/−4
• sample/math/geometry/riemann-curvature-tensor-of-FLRW-metric.egi +17/−7
• sample/math/geometry/riemann-curvature-tensor-of-S2.egi +13/−13
• sample/math/geometry/riemann-curvature-tensor-of-S2xS3.egi +19/−19
• sample/math/geometry/riemann-curvature-tensor-of-S3.egi +12/−12
• sample/math/geometry/riemann-curvature-tensor-of-S4.egi +5/−5
• sample/math/geometry/riemann-curvature-tensor-of-S5-non-sym.egi +2/−0
• sample/math/geometry/riemann-curvature-tensor-of-S5.egi +3/−1
• sample/math/geometry/riemann-curvature-tensor-of-S7.egi +12/−10
• sample/math/geometry/riemann-curvature-tensor-of-Schwarzschild-metric.egi +16/−10
• sample/math/geometry/riemann-curvature-tensor-of-T2.egi +7/−7
• sample/math/geometry/surface.egi +13/−12
• sample/math/geometry/thurston-non-sym.egi +23/−2
• sample/math/geometry/thurston.egi +54/−11
• sample/math/geometry/wedge-product.egi +2/−2
• sample/math/geometry/yang-mills-equation-of-U1-gauge-theory.egi +4/−4
• sample/math/number/17th-root-of-unity.egi +15/−15
• sample/math/number/5th-root-of-unity.egi +33/−23
• sample/math/number/7th-root-of-unity.egi +10/−10
• sample/math/number/eisenstein-primes.egi +2/−2
• sample/math/number/elliptic-curve-over-F7.egi +50/−0
• sample/math/number/gaussian-primes.egi +2/−2
• sample/math/number/tribonacci.egi +9/−6
• sample/physics/tension.egi +6/−6
• sample/physics/tension2.egi +8/−8
• sample/physics/tension3.egi +8/−8
• sample/poker-hands-with-joker.egi +1/−0
• sample/rosetta/partial.egi +4/−4
• sample/salesman.egi +2/−2
• sample/salesman2.egi +2/−2
• sample/sat/cdcl.egi +3/−3
• sample/tree.egi +4/−1
• test/Test.hs +44/−66
• test/lib/core/assoc.egi +5/−5
• test/lib/math/analysis.egi +46/−12
• test/lib/math/arithmetic.egi +8/−3
• test/lib/math/gcd.egi +38/−0
• test/lib/math/groebner.egi +89/−0
• test/lib/math/ideal.egi +27/−0
• test/lib/math/normalize-rules.egi +98/−0
• test/lib/math/quotient-field.egi +26/−0
• test/lib/math/tensor.egi +173/−26
• test/primitive.egi +137/−0
• test/syntax.egi +529/−0
• test/type-error/01-something-cons.egi +9/−0
• test/type-error/02-something-cons-param.egi +12/−0
• test/type-error/03-nested-ctor-element.egi +13/−0
• test/type-error/04-something-tuple-pattern.egi +9/−0
• test/type-error/05-matcher-target-mismatch.egi +11/−0
• test/type-error/06-target-type-mismatch.egi +8/−0
• test/type-error/10-patfun-body-structural.egi +12/−0
• test/type-error/11-patfun-arg-structural.egi +12/−0
• test/type-error/12-patfun-nested-arg-structural.egi +16/−0
• test/type-error/13-patfun-target.egi +15/−0
• test/type-error/14-patfun-arg-target.egi +15/−0
• test/type-error/20-patfun-linearity-unused.egi +10/−0
• test/type-error/21-patfun-linearity-order.egi +10/−0
• test/type-error/22-patfun-linearity-dup.egi +9/−0
• test/type-error/23-patfun-linearity-under-or.egi +9/−0
• test/type-error/30-value-pattern-expr-type.egi +9/−0
• test/type-error/31-nonlinear-target-type.egi +9/−0
• test/type-error/32-or-pattern-bindings.egi +8/−0
• test/type-error/40-matcher-next-structural.egi +20/−0
• test/type-error/41-matcher-body-matchsite.egi +14/−0
• test/type-error/42-tuple-pattern-arity.egi +8/−0
• test/type-error/50-matcher-collection-hetero.egi +16/−0
• test/type-error/51-matcher-cast-structured.egi +5/−0
• test/type-error/52-missing-signature-constraint.egi +8/−0
• test/type-error/53-matcher-alias-specialize.egi +8/−0
• test/type-error/54-something-structured-hole.egi +13/−0
• test/type-error/55-multisite-target-conflict.egi +12/−0
• test/type-error/56-multisite-structural-join.egi +15/−0
• test/type-error/README.md +64/−0

@@ -1,5 +1,56 @@ # Changelog +## 5.1.0++### New Features++* Added an extensible computer-algebra tower with CAS type aliases, subtype+  declarations, runtime dispatch, coercion, and canonical reshaping.+* Added quotient algebras and first-class finite fields, including polynomial+  reduction over declared quotient relations.+* Added multivariate polynomial GCD, Groebner bases, polynomial normal forms,+  and declarative ideals.+* Added user-defined automatic rewrite rules and expanded symbolic+  simplification for radicals, exponentials, and algebraic extensions.+* Added explicit function-symbol metadata, strict differentiation, and unified+  symbolic partial differentiation.+* Added tensor index metadata and higher-order tensor-map lifting.++### Type System and Pattern Matching++* Strengthened matcher consistency and exhaustiveness checking, promoting+  incomplete matcher arms to type errors.+* Improved type-class hierarchy handling, dictionary expansion, instance+  selection, runtime type dispatch, and diagnostics for shadowed class methods.+* Added typing for unannotated top-level recursion.+* Improved inference for tensor callbacks, matcher aliases, structured pattern+  holes, and nonlinear pattern targets.++### Mathematical Libraries++* Added Groebner-basis, ideal, finite-field, algebraic-extension, and interval+  functionality to the standard mathematical libraries.+* Expanded the geometry, algebra, and number-theory samples, including Kahler+  geometry, elliptic curves over finite fields, and CAS-tower examples.+* Improved normalization, matrix and tensor operations, differential forms,+  and root simplification.++### Breaking Changes++* Reorganized the exposed Haskell CAS modules around+  `Language.Egison.Math.CAS`; the former `Math.Arith`, `Math.Expr`, and+  `Math.Normalize` modules are no longer exposed.+* Changed parts of the CAS representation, normalization behavior, symbolic+  function representation, and tensor/matrix APIs. Code relying on Egison 5.0+  implementation details may require updates.++### Testing and Documentation++* Reorganized and expanded the Cabal test suite with CAS, type-error, matcher,+  tensor, quotient-field, and normalization regression tests.+* Added design documentation for the extensible CAS tower, quotient mechanism,+  runtime dispatch, matcher slots, and symbolic simplification.+ ## 5.0.0 ### New Features * **Static Type System**: Introduced a static type system for Egison.

@@ -1,5 +1,5 @@ Name:                egison-Version:             5.0.0+Version:             5.1.0 Synopsis:            Programming language with non-linear pattern-matching against non-free data Description:   An interpreter for Egison, a **pattern-matching-oriented**, purely functional programming language@@ -25,6 +25,7 @@ Category:            Compilers/Interpreters Build-type:          Simple Cabal-version:       2.0+Tested-with:         GHC == 9.10.1  Data-files:          lib/core/*.egi                      lib/math/*.egi@@ -38,8 +39,12 @@ Extra-source-files:  README.md                      benchmark/Benchmark.hs                      benchmark/*.egi+                     test/*.egi                      test/lib/math/*.egi                      test/lib/core/*.egi+                     test/type-error/*.egi+                     test/type-error/README.md+                     sample/STATUS.md                      sample/*.egi                      sample/database/*.egi                      sample/io/*.egi@@ -57,6 +62,11 @@   type: git   location: https://github.com/egison/egison.git +source-repository this+  type: git+  location: https://github.com/egison/egison.git+  tag: 5.1.0+ Library   default-language:    GHC2021   Build-Depends:@@ -100,9 +110,7 @@                   Language.Egison.Eval                    Language.Egison.IExpr                    Language.Egison.Match-                   Language.Egison.Math.Arith-                   Language.Egison.Math.Expr-                   Language.Egison.Math.Normalize+                   Language.Egison.Math.CAS                    Language.Egison.Math.Rewrite                    Language.Egison.Math                    Language.Egison.MathOutput@@ -129,6 +137,7 @@                    Language.Egison.Type.Error                    Language.Egison.Type.Index                    Language.Egison.Type.Infer+                   Language.Egison.Type.Subtype                    Language.Egison.Type.Subst                    Language.Egison.Type.TensorMapInsertion                    Language.Egison.Type.TypeClassExpand@@ -138,6 +147,7 @@                    Language.Egison.Type.Unify                    Language.Egison.Type.Instance                    Language.Egison.Type.Pretty+                   Language.Egison.Type.RuntimeType   Other-modules:   Paths_egison   autogen-modules: Paths_egison   ghc-options:  -Wall -Wno-name-shadowing -Wno-incomplete-patterns

@@ -29,8 +29,8 @@ main = execParser cmdParser >>= runWithOptions  isInValidMathOption :: EgisonOpts -> Bool-isInValidMathOption EgisonOpts{ optMathExpr = Just lang } = lang `notElem` ["asciimath", "latex", "mathematica", "maxima", "haskell"]-isInValidMathOption EgisonOpts{ optMathExpr = Nothing }   = False+isInValidMathOption EgisonOpts{ optMathValue = Just lang } = lang `notElem` ["asciimath", "latex", "mathematica", "maxima", "haskell"]+isInValidMathOption EgisonOpts{ optMathValue = Nothing }   = False  runWithOptions :: EgisonOpts -> IO () runWithOptions opts | isInValidMathOption opts =@@ -66,7 +66,7 @@     env <- initialEnv  -- Only primitive environment     evalTopExprs' env allLoadExprs True True   case mResult of-    Left err  -> liftIO $ print err+    Left err  -> liftIO $ print err >> exitFailure     Right (env, evalState) -> handleOptionWithState env evalState opts  handleOption :: Env -> EgisonOpts -> RuntimeM ()@@ -100,8 +100,8 @@       return ()     -- Execute a script from the main function     EgisonOpts { optExecFile = Just (file, args) } -> do-      result <- fromEvalT $ evalTopExprs env [LoadFile file, Execute (makeApply "main" [CollectionExpr (map (ConstantExpr . StringExpr . T.pack) args)])]-      liftIO $ either print (const $ return ()) result+      result <- fromEvalTWithState evalState $ evalTopExprs env [LoadFile file, Execute (makeApply "main" [CollectionExpr (map (ConstantExpr . StringExpr . T.pack) args)])]+      liftIO $ either print (const $ return ()) (fmap fst result)     EgisonOpts { optMapTsvInput = Just expr } ->       handleOption env (opts { optSubstituteString = Just $ "\\x -> map (" ++ expr ++ ") x" })     EgisonOpts { optFilterTsvInput = Just expr } ->

@@ -22,7 +22,7 @@        , version       ) where -import           Control.Monad.Reader       (asks, local)+import           Control.Monad.Reader       (asks) import           Control.Monad.State  import           Data.Version@@ -69,13 +69,15 @@   , "lib/math/algebra/group.egi"    , "lib/math/common/constants.egi"+  , "lib/math/common/interval.egi"   , "lib/math/common/functions.egi"   , "lib/math/algebra/root.egi"-  , "lib/math/algebra/tensor.egi"    -- Defines (.) (.')+  , "lib/math/algebra/tensor.egi"    -- Defines contractWith, (.) and (.')+  , "lib/math/algebra/matrix.egi"    -- Defines trace, sym and antisym   , "lib/math/algebra/vector.egi"    , "lib/math/algebra/equations.egi"-  , "lib/math/algebra/matrix.egi"+  , "lib/math/algebra/groebner.egi"   , "lib/math/analysis/derivative.egi"    , "lib/math/geometry/differential-form.egi"

@@ -9,6 +9,7 @@  module Language.Egison.AST   ( TopExpr (..)+  , RuleLevel (..)   , ConstantExpr (..)   , Expr (..)   , Pattern (..)@@ -35,6 +36,8 @@   , extractNameFromVarWithIndices   -- Type annotations   , TypeExpr (..)+  , SymbolSetExpr (..)+  , TypeAtomExpr (..)   , TensorShapeExpr (..)   , ShapeDim (..)   , TensorIndexExpr (..)@@ -89,8 +92,73 @@     -- e.g., declare symbol a11, a12, a21, a22     --       declare symbol x, y, z : Float     -- [String]: symbol names, Maybe TypeExpr: optional type (defaults to Integer)+  | DeclareIdeal [Expr]+    -- ^ Ideal declaration (G3 of design/cas-simplification.md).+    -- e.g.  declare ideal [w^2 + w + 1]+    -- Computes the reduced Groebner basis of the generators once (lazily,+    -- via the Egison-level engine in lib/math/algebra/groebner.egi) and+    -- registers the whole basis as one term-level auto rewrite rule.+  | DeclareRule (Maybe String) RuleLevel Pattern Expr+    -- ^ Reduction rule declaration (Phase 7.4 of type-cas design).+    -- e.g.  declare rule auto term i^2 = -1+    --       declare rule trig_pythagorean poly (sin $x)^2 + (cos #x)^2 = 1+    -- Maybe String:  rule name (Nothing = auto rule)+    -- RuleLevel:     where the LHS pattern binds (term/poly/frac)+    -- Pattern Expr:  LHS pattern (with $x/#x), RHS expression+  | DeclareDerivative String Expr+    -- ^ Derivative declaration (Phase 6.3 of type-cas design).+    -- e.g.  declare derivative sin = cos+    --       declare derivative log = \x -> 1 / x+    -- String: name of the function whose derivative is being declared+    --         (typically introduced by `declare mathfunc` first).+    -- Expr:   the derivative-as-an-expression (typically a function or lambda)+  | DeclareMathFunc String (Maybe TypeExpr)+    -- ^ Math function declaration (Phase 6.3 part 5).+    -- e.g.  declare mathfunc sin+    --       declare mathfunc sqrt : MathValue -> MathValue+    -- Desugars to a wrapper function that quotes the symbol:+    --   def <name> (x : MathValue) : MathValue := '<name> x+    -- Combined with `declare derivative`, this gives the user a callable+    -- function and a registered derivative under one umbrella.+  | DeclareCasType String TypeExpr+    -- ^ Transparent CAS type alias (Phase alpha of the extensible tower;+    -- design/type-cas-tower.md D3: transparent aliases only, no nominal types).+    -- e.g.  declare cas-type GaussianInt := Poly Integer [i]+    -- String: alias name (must be capitalized), TypeExpr: the aliased type.+    -- Expanded away during environment building / desugaring; no runtime artifact.+  | DeclareCasSubtype TypeExpr TypeExpr+    -- ^ Subtype-order edge declaration (Phase beta; design D1/D5).+    -- e.g.  declare cas-subtype Poly Integer [i, x] <: Poly (Poly Integer [i]) [x]+    --       declare cas-subtype Integer ⊂ GaussianInt+    -- Relation only (D5: no embed clause — promotion is always casReshapeAs).+    -- Checked at declare time for the D1 join-semilattice invariant.+  | DeclareCasQuotient String TypeExpr Expr+    -- ^ Coefficient-domain quotient declaration (M4; design/type-cas-quotient.md).+    -- e.g.  declare cas-quotient Mod7 := Integer by (\n -> modulo n 7)+    -- String: nominal quotient type name; TypeExpr: base type; Expr: the+    -- idempotent reduce (representative selector). Macro-expanded before+    -- environment building into reduce<Q>/proj<Q>/repr<Q> definitions,+    -- homomorphic Ring/Eq instances, and congruence-law assertions.+  | DeclareApply String [String] Expr+    -- ^ Math function application rule (Phase A of declare apply impl).+    -- e.g.  declare apply sin x := if x = 0 then 0 else 'sin x+    --       declare apply sqrt x := ...+    -- String:    function name (must have been declared via `declare mathfunc`).+    -- [String]:  argument names (typed as MathValue by default).+    -- Expr:      body. Within body, `'<name> x` produces the symbolic Factor+    --            (no recursion); `<name> x` (unquoted) recurses through this+    --            rule again — RHS must use `'` for the fallback to terminate.+    -- Phase A desugars to a plain `def <name> (args : MathValue ...) : MathValue := <body>`+    -- which simply overrides the wrapper from `declare mathfunc`.  deriving Show +-- | Where in the CASValue tree a `declare rule` LHS pattern binds.+data RuleLevel+  = TermRuleLevel  -- ^ inside a CASTerm monomial (e.g. i^2 = -1)+  | PolyRuleLevel  -- ^ inside a CASPoly term-list  (e.g. (sin x)^2 + (cos x)^2 = 1)+  | FracRuleLevel  -- ^ on a CASFrac  numerator/denominator+  deriving (Show, Eq)+ -- | Type class declaration -- e.g., class Eq a where ... --       class Eq a => Ord a where ...@@ -224,6 +292,7 @@   | FunctionExpr [String]    | TypeAnnotation Expr TypeExpr  -- ^ Expression with type annotation (expr : type)+  | SimplifyUsingExpr Expr String -- ^ Phase 7.6: `simplify <expr> using <ruleName>`. Skeleton: parser only — runtime semantics will appear when the rule-application engine lands.   deriving Show  data VarWithIndices = VarWithIndices String [VarIndex]@@ -327,20 +396,20 @@   | PDConsPat (PDPatternBase var) (PDPatternBase var)   | PDSnocPat (PDPatternBase var) (PDPatternBase var)   | PDConstantPat ConstantExpr-  -- ScalarData (MathExpr) primitive patterns-  | PDDivPat (PDPatternBase var) (PDPatternBase var)        -- Div: ScalarData -> PolyExpr, PolyExpr+  -- MathValue primitive patterns+  | PDFracPat (PDPatternBase var) (PDPatternBase var)        -- Frac: MathValue -> PolyExpr, PolyExpr   | PDPlusPat (PDPatternBase var)                           -- Plus: PolyExpr -> [TermExpr]   | PDTermPat (PDPatternBase var) (PDPatternBase var)       -- Term: TermExpr -> Integer, [(SymbolExpr, Integer)]   | PDSymbolPat (PDPatternBase var) (PDPatternBase var)     -- Symbol: SymbolExpr -> String, [IndexExpr]-  | PDApply1Pat (PDPatternBase var) (PDPatternBase var)     -- Apply1: SymbolExpr -> MathExpr, MathExpr+  | PDApply1Pat (PDPatternBase var) (PDPatternBase var)     -- Apply1: SymbolExpr -> MathValue, MathValue   | PDApply2Pat (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) -- Apply2   | PDApply3Pat (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) -- Apply3   | PDApply4Pat (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) (PDPatternBase var) -- Apply4-  | PDQuotePat (PDPatternBase var)                          -- Quote: SymbolExpr -> MathExpr-  | PDFunctionPat (PDPatternBase var) (PDPatternBase var) -- Function: SymbolExpr -> MathExpr, [MathExpr]-  | PDSubPat (PDPatternBase var)                            -- Sub: IndexExpr -> MathExpr-  | PDSupPat (PDPatternBase var)                            -- Sup: IndexExpr -> MathExpr-  | PDUserPat (PDPatternBase var)                           -- User: IndexExpr -> MathExpr+  | PDQuotePat (PDPatternBase var)                          -- Quote: SymbolExpr -> MathValue+  | PDFunctionPat (PDPatternBase var) (PDPatternBase var) -- Function: SymbolExpr -> MathValue, [MathValue]+  | PDSubPat (PDPatternBase var)                            -- Sub: IndexExpr -> MathValue+  | PDSupPat (PDPatternBase var)                            -- Sup: IndexExpr -> MathValue+  | PDUserPat (PDPatternBase var)                           -- User: IndexExpr -> MathValue   deriving (Functor, Foldable, Show)  type PrimitiveDataPattern = PDPatternBase String@@ -403,6 +472,7 @@   [ Op "++" 5 InfixR False   , Op "*:" 5 InfixL False   , Op "+" 7 InfixR False+  , Op "-" 7 InfixL False  -- subtraction in rule LHS, e.g. `1 - $x`   , Op "*" 8 InfixR False   , Op "/" 8 InfixN False   , Op "^" 9 InfixN False@@ -429,8 +499,8 @@  -- | Type expression in source code data TypeExpr-  = TEInt                              -- ^ Integer (= MathExpr)-  | TEMathExpr                         -- ^ MathExpr (= Integer)+  = TEInt                              -- ^ Integer (= MathValue)+  | TEMathValue                         -- ^ MathValue (= Integer)   | TEFloat                            -- ^ Float   | TEBool                             -- ^ Bool   | TEChar                             -- ^ Char@@ -440,6 +510,7 @@   | TETuple [TypeExpr]                 -- ^ Tuple type, e.g., (a, b)   | TEFun TypeExpr TypeExpr            -- ^ Function type, e.g., a -> b   | TEMatcher TypeExpr                 -- ^ Matcher type+  | TEMatcherSlot TypeExpr TypeExpr    -- ^ MatcherSlot type, e.g., MatcherSlot a a (structural / target)   | TEPattern TypeExpr                 -- ^ Pattern type, e.g., Pattern a   | TEIO TypeExpr                      -- ^ IO type, e.g., IO ()   | TETensor TypeExpr                  -- ^ Tensor type, e.g., Tensor a@@ -449,7 +520,28 @@   | TEApp TypeExpr [TypeExpr]          -- ^ Type application, e.g., List a   | TEConstrained [ConstraintExpr] TypeExpr                                       -- ^ Constrained type, e.g., Eq a => a+  -- New CAS types (Phase 2)+  | TEFactor                           -- ^ Factor type (atomic mathematical factor)+  | TETerm TypeExpr SymbolSetExpr      -- ^ Term type, e.g., Term Integer [x] (single monomial over the given atoms)+  | TEFrac TypeExpr                     -- ^ Frac type, e.g., Frac Integer+  | TEPoly TypeExpr SymbolSetExpr      -- ^ Poly type, e.g., Poly Integer [x, y]   deriving (Show, Eq)++-- | Symbol set expression for polynomial types+data SymbolSetExpr+  = SSEClosed [TypeAtomExpr]            -- ^ Fixed symbol set, e.g., [x, y, sqrt 2]+  | SSEOpen                             -- ^ Open symbol set, [..]+  deriving (Show, Eq)++-- | A single atom inside a closed symbol set: either a plain identifier+-- (`x`, `i`), or a function applied to atom arguments (`sqrt 2`, `sin x`).+-- This is the AST level (parser output); the Type level uses a similar+-- structure (`TypeAtom` in Type.Types).+data TypeAtomExpr+  = TAEName String                      -- ^ Plain symbol/identifier+  | TAEApp String [TypeAtomExpr]        -- ^ Function applied to atom arguments+  | TAEInt Integer                      -- ^ Integer literal in atom position+  deriving (Show, Eq, Ord)  -- | Tensor shape expression data TensorShapeExpr

@@ -34,7 +34,7 @@     optShowBanner       :: Bool,     optTestOnly         :: Bool,     optPrompt           :: String,-    optMathExpr         :: Maybe String,+    optMathValue         :: Maybe String,     optMathNormalize    :: Bool,     optTypeCheck        :: Bool,       -- ^ Enable type checking     optTypeCheckStrict  :: Bool,       -- ^ Strict type checking mode@@ -42,11 +42,12 @@     optDumpDesugared    :: Bool,       -- ^ Dump desugared AST after Phase 3     optDumpTyped        :: Bool,       -- ^ Dump typed AST after Phase 6 (type inference & check)     optDumpTi           :: Bool,       -- ^ Dump typed AST after TensorMap insertion (before type class expansion)-    optDumpTc           :: Bool        -- ^ Dump typed AST after type class expansion (Phase 8 complete)+    optDumpTc           :: Bool,       -- ^ Dump typed AST after type class expansion (Phase 7 complete)+    optMatcherConsistencyWarnings :: Bool        -- ^ Emit matcher consistency warnings (paper Def 4.2: Coverage 4.2(3) + PP-Con 4.2(1a)); arm exhaustiveness (4.2(1c)) is an ordinary type error, not gated here     }  defaultOption :: EgisonOpts-defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False False True False "> " Nothing True True False False False False False False+defaultOption = EgisonOpts Nothing False Nothing Nothing [] [] [] Nothing Nothing Nothing False False False True False "> " Nothing True True False False False False False False False --                                                                                                     ^^^^^ optNoPrelude --                                                                                                                                      ^^^^ optTypeCheck is now True by default --                                                                                                                                              ^^^^^ optDumpEnv@@ -156,7 +157,10 @@                   <> help "Dump typed AST after TensorMap insertion (before type class expansion)")             <*> switch                   (long "dump-tc"-                  <> help "Dump typed AST after type class expansion (Phase 8 complete)")+                  <> help "Dump typed AST after type class expansion (Phase 7 complete)")+            <*> switch+                  (long "matcher-consistency-warnings"+                  <> help "Emit matcher consistency warnings (paper Def 4.2): Coverage (4.2(3)) — a matcher lacking a general clause for some pattern constructor of its matched type; and PP-Con (4.2(1a)) — a bare-variable matcher `something` at a constructor-headed next-matcher hole. Arm exhaustiveness (4.2(1c)) is an ordinary type error, not gated by this flag")  readFieldOption :: ReadM (String, String) readFieldOption = eitherReader $ \str ->

@@ -7,10 +7,10 @@ Module      : Language.Egison.Core Licence     : MIT -This module implements Phase 10: Evaluation.+This module implements Phase 9: Evaluation. It provides functions to evaluate expressions and perform pattern matching. -Evaluation Phase (Phase 10):+Evaluation Phase (Phase 9):   - Pattern matching execution (patternMatch function)     * Egison's powerful non-linear pattern matching with backtracking     * Pattern matching is NOT desugared but executed during evaluation@@ -38,6 +38,9 @@     , recursiveBindPatFuncs     , recursiveBindAll     , makeBindings'+    -- * Function application (used by primitives that take user closures)+    , applyRef+    , applyObj     -- * Pattern matching     , patternMatch     ) where@@ -50,18 +53,16 @@ import           Control.Monad.State import           Control.Monad.Trans.Maybe -import           Data.Char                       (isUpper)+import           Data.Char                       (isUpper, toLower) import           Data.Foldable                   (toList) import           Data.IORef-import           Data.List                       (partition)+import           Data.List                       (partition, sortOn) import           Data.Maybe import qualified Data.Sequence                   as Sq import           Data.Traversable                (mapM)  import qualified Data.HashMap.Lazy               as HL-import qualified Data.HashMap.Strict             as HashMap import qualified Data.Vector                     as V-import           Data.Text                       (Text) import qualified Data.Text                       as T  import           Language.Egison.Data@@ -71,18 +72,19 @@ import           Language.Egison.IExpr import           Language.Egison.MList import           Language.Egison.Match-import           Language.Egison.Math+import qualified Language.Egison.Math.CAS as CAS import           Language.Egison.RState import           Language.Egison.Tensor import           Language.Egison.Type.Types      (Type(..))+import qualified Language.Egison.Type.RuntimeType as RT+import           Language.Egison.Type.Instance   (selectMostSpecific)+import           Language.Egison.Type.Subtype    (SubtypeEnv, isSubtypeWith, isCasType)  -- | Get the Type of an EgisonValue -- Used for type class method dispatch valueToType :: EgisonValue -> Type valueToType (Bool _)         = TBool-valueToType (ScalarData (Div (Plus []) (Plus [Term 1 []])))          = TInt-valueToType (ScalarData (Div (Plus [Term _ []]) (Plus [Term 1 []]))) = TInt-valueToType (ScalarData _)   = TInt  -- MathExpr = TInt in Egison+valueToType (CASData _)      = TInt  -- MathValue = TInt in Egison valueToType (Float _)        = TFloat valueToType (Char _)         = TChar valueToType (String _)       = TString@@ -126,8 +128,8 @@ evalExprShallow env (IQuoteExpr expr) = do   whnf <- evalExprShallow env expr   case whnf of-    Value (ScalarData s) -> return . Value . ScalarData $ SingleTerm 1 [(Quote s, 1)]-    _                    -> throwErrorWithTrace (TypeMismatch "scalar in quote" whnf)+    Value (CASData cv) -> return $ Value (quoteCASData cv)+    _                  -> throwErrorWithTrace (TypeMismatch "scalar in quote" whnf)  evalExprShallow env (IQuoteSymbolExpr expr) =   case expr of@@ -137,26 +139,26 @@         Just ref -> do           val <- evalRef ref           case val of-            Value func@(Func _ _ _ _) -> +            Value (Func _ _ _ _) ->               -- Quote the function object itself-              return . Value . ScalarData $ SingleTerm 1 [(QuoteFunction val, 1)]-            Value func@(MemoizedFunc _ _ _ _) -> +              return $ Value (quoteFunctionCASData val)+            Value (MemoizedFunc _ _ _ _) ->               -- Quote the memoized function object itself-              return . Value . ScalarData $ SingleTerm 1 [(QuoteFunction val, 1)]-            Value (ScalarData _) -> return val-            _ -> return . Value $ symbolScalarData "" name-        Nothing -> return . Value $ symbolScalarData "" name+              return $ Value (quoteFunctionCASData val)+            Value (CASData _) -> return val+            _ -> return $ Value (symbolCASData "" name)+        Nothing -> return $ Value (symbolCASData "" name)     _ -> do       whnf <- evalExprShallow env expr       case whnf of-        Value (ScalarData _) -> return whnf-        _                    -> throwErrorWithTrace (TypeMismatch "scalar or symbol in quote-symbol" whnf)+        Value (CASData _) -> return whnf+        _                 -> throwErrorWithTrace (TypeMismatch "scalar or symbol in quote-symbol" whnf)  evalExprShallow env (IVarExpr name) =   case refVar env (Var name []) of-    Nothing | isUpper (head name) ->+    Nothing | (c:_) <- name, isUpper c ->       return $ Value (InductiveData name [])-    Nothing  -> return $ Value (symbolScalarData "" name)+    Nothing  -> return $ Value (symbolCASData "" name)     Just ref -> evalRef ref  evalExprShallow _ (ITupleExpr []) = return . Value $ Tuple []  -- Unit value ()@@ -224,10 +226,10 @@   makeHashKey :: WHNFData -> EvalM EgisonHashKey   makeHashKey (Value val) =     case val of-      ScalarData _ -> IntKey <$> fromEgison val-      Char c       -> return (CharKey c)-      String str   -> return (StrKey str)-      _            -> throwErrorWithTrace (TypeMismatch "integer or string" (Value val))+      CASData _ -> IntKey <$> fromEgison val+      Char c    -> return (CharKey c)+      String str-> return (StrKey str)+      _         -> throwErrorWithTrace (TypeMismatch "integer or string" (Value val))   makeHashKey whnf = throwErrorWithTrace (TypeMismatch "integer or string" whnf)  evalExprShallow env@(Env _fs _ _) (IIndexedExpr override expr indices) = do@@ -240,14 +242,12 @@                   Nothing     -> evalExprShallow env expr               _ -> evalExprShallow env expr   case whnf of-    Value (ScalarData (SingleTerm 1 [(Symbol id name js', 1)])) -> do-      js2 <- mapM evalIndexToScalar indices-      return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (js' ++ js2), 1)]))+    Value (CASData (CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol symId name js', 1)]])) -> do+      js2 <- mapM evalIndexToCAS indices+      return $ Value $ CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol symId name (js' ++ js2), 1)]]     Value (Func v@(Just (Var _fnName is)) env args body) -> do       js <- mapM evalIndex indices-      liftIO $ putStrLn $ "[DEBUG pmIndices] is: " ++ show is ++ ", js: " ++ show js       frame <- pmIndices is js-      liftIO $ putStrLn $ "can reach here"       let env' = extendEnv env frame       return $ Value (Func v env' args body)     Value (TensorData t@Tensor{}) -> do@@ -263,9 +263,13 @@   evalIndex :: Index IExpr -> EvalM (Index EgisonValue)   evalIndex index = traverse (evalExprDeep env) index -  evalIndexToScalar :: Index IExpr -> EvalM (Index ScalarData)-  evalIndexToScalar index = traverse ((extractScalar =<<) . evalExprDeep env) index+  evalIndexToCAS :: Index IExpr -> EvalM (Index CASValue)+  evalIndexToCAS index = traverse (evalExprDeep env >=> extractCASValue) index +  extractCASValue :: EgisonValue -> EvalM CASValue+  extractCASValue (CASData cv) = return cv+  extractCASValue val = throwErrorWithTrace (TypeMismatch "CASData" (Value val))+ evalExprShallow env (ISubrefsExpr override expr jsExpr) = do   js <- map Sub <$> (evalExprDeep env jsExpr >>= collectionToList)   tensor <- case expr of@@ -276,13 +280,13 @@                   Nothing     -> evalExprShallow env expr               _ -> evalExprShallow env expr   case tensor of-    Value (ScalarData _)          -> return tensor-    Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t-    ITensor t@Tensor{}            -> refTensorWithOverride override js t+    Value (CASData _)               -> return tensor+    Value (TensorData t@Tensor{})   -> Value <$> refTensorWithOverride override js t+    ITensor t@Tensor{}              -> refTensorWithOverride override js t     _ -> do       val <- evalWHNF tensor       case val of-        ScalarData _          -> return $ Value val+        CASData _             -> return $ Value val         TensorData t@Tensor{} -> Value <$> refTensorWithOverride override js t         _                     -> throwErrorWithTrace (NotImplemented ("subrefs for " ++ show val)) @@ -296,30 +300,77 @@                   Nothing     -> evalExprShallow env expr               _ -> evalExprShallow env expr   case tensor of-    Value (ScalarData _)          -> return tensor-    Value (TensorData t@Tensor{}) -> Value <$> refTensorWithOverride override js t-    ITensor t@Tensor{}            -> refTensorWithOverride override js t+    Value (CASData _)               -> return tensor+    Value (TensorData t@Tensor{})   -> Value <$> refTensorWithOverride override js t+    ITensor t@Tensor{}              -> refTensorWithOverride override js t     _ -> do       val <- evalWHNF tensor       case val of-        ScalarData _          -> return $ Value val+        CASData _             -> return $ Value val         TensorData t@Tensor{} -> Value <$> refTensorWithOverride override js t         _                     -> throwErrorWithTrace (NotImplemented ("suprefs for " ++ show val))  evalExprShallow env (IUserrefsExpr _ expr jsExpr) = do   val <- evalExprDeep env expr-  js <- map User <$> (evalExprDeep env jsExpr >>= collectionToList >>= mapM extractScalar)+  jsRaw <- evalExprDeep env jsExpr >>= collectionToList >>= mapM extractCASVal+  let jsCAS = map User jsRaw   case val of-    ScalarData (SingleTerm 1 [(Symbol id name is, 1)]) ->-      return $ Value (ScalarData (SingleTerm 1 [(Symbol id name (is ++ js), 1)]))-    ScalarData (SingleTerm 1 [(FunctionData sym args, 1)]) ->+    -- A bare symbol takes user indices verbatim (indexed-symbol feature,+    -- unrelated to derivative marks).+    CASData (CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol symId name is, 1)]]) ->+      return $ Value $ CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol symId name (is ++ jsCAS), 1)]]+    -- On a function symbol the user indices are DERIVATIVE MARKS, and are+    -- normalized at construction: an argument value resolves to its+    -- position (the arguments are values, not names, so a positional+    -- multi-index is the only well-defined form), positions are+    -- range-checked, and the combined multi-index is kept sorted --+    -- mixed partials of the smooth unknown functions these stand for+    -- commute (Schwarz), so f|2|1 and f|1|2 must be the same atom.+    CASData (CASPoly [CASTerm (CASInteger 1) [(CAS.FunctionData sym args, 1)]]) ->       case sym of-        SingleTerm 1 [(Symbol id name is, 1)] -> do-          let sym' = SingleTerm 1 [(Symbol id name (is ++ js), 1)]-          return $ Value (ScalarData (SingleTerm 1 [(FunctionData sym' args, 1)]))+        CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol symId name is, 1)]] -> do+          posIdxs <- mapM (resolveFnIndex name args) jsRaw+          let (users, others) = partition isUserIndex is+              users' = sortOn userKey (users ++ map (User . CASInteger) posIdxs)+              sym' = CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol symId name (others ++ users'), 1)]]+          return $ Value $ CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.FunctionData sym' args, 1)]]         _ -> throwErrorWithTrace (NotImplemented "user-refs")     _ -> throwErrorWithTrace (NotImplemented "user-refs")+ where+  extractCASVal :: EgisonValue -> EvalM CASValue+  extractCASVal (CASData cv) = return cv+  extractCASVal v = throwErrorWithTrace (TypeMismatch "CASData" (Value v)) +  resolveFnIndex :: String -> [CASValue] -> CASValue -> EvalM Integer+  resolveFnIndex name args j = case casToSmallInt j of+    Just n+      | 1 <= n && n <= fromIntegral (length args) -> return n+      | otherwise -> throwError $ Default $+          "userRefs: index " ++ show n ++ " is out of range for the "+          ++ show (length args) ++ "-argument function symbol " ++ name+    Nothing -> case [i | (i, a) <- zip [1..] args, a == j] of+      [i] -> return i+      []  -> throwError $ Default $+          "userRefs: " ++ CAS.prettyCAS j ++ " is not an argument of the function symbol " ++ name+      _   -> throwError $ Default $+          "userRefs: " ++ CAS.prettyCAS j ++ " appears more than once among the arguments of "+          ++ name ++ "; use a positional index"++  casToSmallInt :: CASValue -> Maybe Integer+  casToSmallInt (CASInteger n) = Just n+  casToSmallInt (CASPoly [CASTerm (CASInteger n) []]) = Just n+  casToSmallInt (CASFrac num (CASInteger 1)) = casToSmallInt num+  casToSmallInt (CASFrac num (CASPoly [CASTerm (CASInteger 1) []])) = casToSmallInt num+  casToSmallInt _ = Nothing++  isUserIndex :: Index a -> Bool+  isUserIndex (User _) = True+  isUserIndex _        = False++  userKey :: Index CASValue -> Integer+  userKey (User v) = fromMaybe (toInteger (maxBound :: Int)) (casToSmallInt v)+  userKey _        = toInteger (maxBound :: Int)+ evalExprShallow env (ILambdaExpr vwi names expr) = do   return . Value $ Func vwi env names expr @@ -332,12 +383,16 @@ evalExprShallow (Env _ Nothing _) (IFunctionExpr _) = throwError $ Default "function symbol is not bound to a variable"  evalExprShallow env@(Env _ (Just (name, is)) _) (IFunctionExpr args) = do-  args' <- mapM (evalExprDeep env . IVarExpr) args >>= mapM extractScalar+  args' <- mapM (evalExprDeep env . IVarExpr) args >>= mapM extractCASVal   is' <- mapM unwrapMaybeFromIndex is-  return . Value $ ScalarData (SingleTerm 1 [(FunctionData (SingleTerm 1 [(Symbol "" name is', 1)]) args', 1)])+  let sym = CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol "" name is', 1)]]+  return $ Value $ CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.FunctionData sym args', 1)]]  where-  unwrapMaybeFromIndex :: Index (Maybe ScalarData) -> EvalM (Index ScalarData) -- Maybe we can refactor this function---  unwrapMaybeFromIndex = return . (fmap fromJust)+  extractCASVal :: EgisonValue -> EvalM CASValue+  extractCASVal (CASData cv) = return cv+  extractCASVal v = throwErrorWithTrace (TypeMismatch "CASData" (Value v))++  unwrapMaybeFromIndex :: Index (Maybe CASValue) -> EvalM (Index CASValue)   unwrapMaybeFromIndex (Sub Nothing) = throwError $ Default "function symbol can be used only with generateTensor"   unwrapMaybeFromIndex (Sup Nothing) = throwError $ Default "function symbol can be used only with generateTensor"   unwrapMaybeFromIndex (Sub (Just i)) = return (Sub i)@@ -379,7 +434,7 @@  evalExprShallow env (IWithSymbolsExpr vars expr) = do   symId <- fresh-  syms <- mapM (newEvaluatedObjectRef . Value . symbolScalarData symId) vars+  syms <- mapM (newEvaluatedObjectRef . Value . symbolCASData symId) vars   whnf <- evalExprShallow (extendEnv env (makeBindings' vars syms)) expr   case whnf of     Value (TensorData t@Tensor{}) -> Value . TensorData <$> removeTmpScripts symId t@@ -490,17 +545,27 @@ evalExprShallow env (IGenerateTensorExpr fnExpr shapeExpr) = do   shape <- evalExprDeep env shapeExpr >>= collectionToList   ns    <- mapM fromEgison shape :: EvalM Shape-  xs    <- mapM (evalWithIndex env . map (\n -> SingleTerm n [])) (enumTensorIndices ns)-  return $ newITensor ns xs+  xs    <- mapM (evalWithIndex env . map CASInteger) (enumTensorIndices ns)+  newITensor ns xs  where-  evalWithIndex :: Env -> [ScalarData] {- index -} -> EvalM ObjectRef+  evalWithIndex :: Env -> [CASValue] {- index -} -> EvalM ObjectRef   evalWithIndex env@(Env frame maybe_vwi pfEnv) ms = do-    let env' = maybe env (\(name, indices) -> Env frame (Just (name, zipWith changeIndex indices ms)) pfEnv) maybe_vwi+    let env' = maybe env (\(name, indices) ->+          -- Omitted tensor axes are covariant by default.  Complete the+          -- definition context so function-symbol components of a bare+          -- tensor binding still receive their component-position names.+          -- Preserve positions completed by outer generateTensor calls.+          Env frame (Just (name, fillIndices indices ms)) pfEnv) maybe_vwi     fn <- evalExprShallow env' fnExpr-    newApplyObjThunkRef env fn [WHNF (Value (Collection (Sq.fromList (map ScalarData ms))))]-  changeIndex :: Index (Maybe a) -> a -> Index (Maybe a) -- Maybe we can refactor this function-  changeIndex (Sup Nothing) m = Sup (Just m)-  changeIndex (Sub Nothing) m = Sub (Just m)+    newApplyObjThunkRef env fn [WHNF (Value (Collection (Sq.fromList (map CASData ms))))]+  fillIndices :: [Index (Maybe a)] -> [a] -> [Index (Maybe a)]+  fillIndices indices [] = indices+  fillIndices [] ms = map (Sub . Just) ms+  fillIndices (Sup Nothing : indices) (m : ms) =+    Sup (Just m) : fillIndices indices ms+  fillIndices (Sub Nothing : indices) (m : ms) =+    Sub (Just m) : fillIndices indices ms+  fillIndices (index : indices) ms = index : fillIndices indices ms  evalExprShallow env (ITensorContractExpr tExpr) = do   whnf <- evalExprShallow env tExpr@@ -588,6 +653,89 @@   -- Create a PatternFunc value, capturing the current environment   return $ Value (PatternFunc env paramNames body) +-- Reshape (Phase A of design/type-cas-implementation-status.md §reshape).+-- Inserted by post-typecheck elaboration from a type annotation. At eval time+-- we structurally rewrite the inner CAS value to fit the annotation's type.+-- Non-CAS values pass through unchanged.+evalExprShallow env (IReshape ty inner) = do+  whnf <- evalExprShallow env inner+  case whnf of+    Value (CASData cv) -> return $ Value $ CASData (CAS.casReshapeAs ty cv)+    _                  -> return whnf++-- Runtime-type dispatch (Phase 3 of design/runtime-type-dispatch.md).+-- TypeClassExpand emits this node when a type-class method is called on a+-- value whose static type is `MathValue` and no explicit+-- `instance Class MathValue` exists. We:+--   1. evaluate the first argument to get the CAS value+--   2. compute its shallow runtime type+--   3. pick the dictionary for the most specific candidate+--   4. construct the equivalent dictionary-indexed application and evaluate.+evalExprShallow env (IRuntimeDispatch className methodName candidates args) = do+  case args of+    [] ->+      throwError $ Default $+        "runtime dispatch: no arguments for " ++ className ++ "." ++ methodName+    (firstArg : restArgs) -> do+      -- Evaluate the first argument exactly once. We cannot re-emit+      -- `IApplyExpr (IIndexedExpr (IVarExpr dictName)) args` here because+      -- `IApplyExpr` re-thunks every IExpr arg, which would re-evaluate+      -- `firstArg` from scratch (defeating the work we already did to+      -- compute its CAS shape). For deeply nested recursive partialDiff+      -- calls (e.g. tensor-Christoffel), that doubling compounds and+      -- causes orders-of-magnitude slowdown. So we reuse the WHNFData by+      -- wrapping it in an evaluated ObjectRef and call `applyRef`+      -- directly with cached ref + thunked rest args.+      firstWhnf <- evalExprShallow env firstArg+      cv <- case firstWhnf of+        Value (CASData c) -> return c+        _ -> throwErrorWithTrace+               (TypeMismatch ("CASData (for " ++ className ++ "." ++ methodName ++ " runtime dispatch)") firstWhnf)+      let rt = RT.runtimeTypeOfCAS cv+      edges <- getCasSubtypeEdges+      -- The candidate list omits the class's MathValue instance (the+      -- expander's self-selection guard), so a value whose runtime type+      -- is a plain CAS shape -- e.g. a let-generalized combination that+      -- collapses to the integer 0 at some call site -- may match no+      -- candidate.  Fall back to the MathValue dictionary then: call+      -- sites inside that instance are typed TMathValue and never emit+      -- a dispatch node, so this cannot loop.+      let mvDict = mvDictName className+          runDict dictName = do+            dictWhnf   <- evalExprShallow env (IVarExpr dictName)+            methodWhnf <- refHash dictWhnf [String (T.pack methodName)]+            firstRef   <- newEvaluatedObjectRef firstWhnf+            restRefs   <- mapM (newThunkRef env) restArgs+            applyRef env methodWhnf (firstRef : restRefs) >>= removeDF+      case findBestRuntimeCandidate edges rt candidates of+        Just dictName -> runDict dictName+        Nothing+          | isCasType rt, isJust (refVar env (stringToVar mvDict)) ->+              runDict mvDict+        Nothing ->+          throwError $ Default $+            "runtime dispatch: no matching instance for "+              ++ className ++ " on value of runtime type " ++ show rt+  where+    -- Pick the dictionary name whose instance type is the most specific+    -- supertype of `target`, in the declared CAS order (skeleton ++    -- `declare cas-subtype` edges). Candidate filtering is by plain+    -- subtyping (runtime types are concrete); selection is the shared+    -- `Type.Instance.selectMostSpecific`.+    findBestRuntimeCandidate :: SubtypeEnv -> Type -> [(Type, String)] -> Maybe String+    findBestRuntimeCandidate edges target cands =+      case selectMostSpecific edges (\(t, _) -> [t]) [target]+             (filter (\(t, _) -> isSubtypeWith edges target t) cands) of+        Right (_, dn) -> Just dn+        Left _        -> Nothing++    -- dictionary variable of the class's MathValue instance, following+    -- the expander's naming scheme (lowerFirst class ++ type names)+    mvDictName :: String -> String+    mvDictName cn = case cn of+      (c:cs) -> toLower c : cs ++ "MathValue"+      []     -> "MathValue"+ evalExprShallow _ expr = throwErrorWithTrace (NotImplemented ("evalExprShallow for " ++ show expr))  evalExprDeep :: Env -> IExpr -> EvalM EgisonValue@@ -649,15 +797,22 @@ newApplyObjThunkRef :: Env -> WHNFData -> [Object] -> EvalM ObjectRef newApplyObjThunkRef env fn objs = liftIO . newIORef $ newApplyObjThunk env fn objs +-- | Helper for applyRef: check if a tensor WHNFData has shape rank exactly+-- one greater than its index count (= one DF-pending dimension). Other+-- WHNFData shapes return False so we never use a partial pattern match.+isTensorWithDFOne :: WHNFData -> Bool+isTensorWithDFOne (ITensor (Tensor s _ i)) = length s - length i == 1+isTensorWithDFOne _                        = False+ applyRef :: Env -> WHNFData -> [ObjectRef] -> EvalM WHNFData applyRef env (Value (TensorData (Tensor s1 t1 i1))) refs = do   tds <- mapM evalRef refs-  if length s1 > length i1 && all (\(ITensor (Tensor s _ i)) -> length s - length i == 1) tds+  if length s1 > length i1 && all isTensorWithDFOne tds     then do       symId <- fresh       let argnum = length tds-          subjs = map (Sub . symbolScalarData symId . show) [1 .. argnum]-          supjs = map (Sup . symbolScalarData symId . show) [1 .. argnum]+          subjs = map (Sub . symbolCASData symId . show) [1 .. argnum]+          supjs = map (Sup . symbolCASData symId . show) [1 .. argnum]       dot <- evalExprShallow env (IVarExpr ".")       tds' <- mapM toTensor tds       let args' = Value (TensorData (Tensor s1 t1 (i1 ++ supjs))) : map (ITensor . addscript) (zip subjs tds')@@ -665,12 +820,12 @@     else throwError $ Default "applyObj" applyRef env (ITensor (Tensor s1 t1 i1)) refs = do   tds <- mapM evalRef refs-  if length s1 > length i1 && all (\(ITensor (Tensor s _ i)) -> length s - length i == 1) tds+  if length s1 > length i1 && all isTensorWithDFOne tds     then do       symId <- fresh       let argnum = length tds-          subjs = map (Sub . symbolScalarData symId . show) [1 .. argnum]-          supjs = map (Sup . symbolScalarData symId . show) [1 .. argnum]+          subjs = map (Sub . symbolCASData symId . show) [1 .. argnum]+          supjs = map (Sup . symbolCASData symId . show) [1 .. argnum]       dot <- evalExprShallow env (IVarExpr ".")       tds' <- mapM toTensor tds       let args' = ITensor (Tensor s1 t1 (i1 ++ supjs)) : map (ITensor . addscript) (zip subjs tds')@@ -705,30 +860,30 @@   case args of     [Value World] -> m     arg : _       -> throwErrorWithTrace (TypeMismatch "world" arg)-applyRef _ (Value (ScalarData (SingleTerm 1 [(FunctionData sym args, 1)]))) refs = do+applyRef _ (Value (CASData (CASPoly [CASTerm (CASInteger 1) [(CAS.FunctionData sym args, 1)]]))) refs = do   newArgs <- mapM (\ref -> evalRef ref >>= evalWHNF) refs-  newScalars <- mapM (\arg -> case arg of-    ScalarData s -> return s-    _ -> throwErrorWithTrace (TypeMismatch "scalar" (Value arg))) newArgs-  when (length newScalars /= length args) $+  newCASVals <- mapM (\arg -> case arg of+    CASData c -> return c+    _         -> throwErrorWithTrace (TypeMismatch "scalar" (Value arg))) newArgs+  when (length newCASVals /= length args) $     throwError (Default ("function applied to wrong number of arguments: expected "-      ++ show (length args) ++ ", got " ++ show (length newScalars)))-  return $ Value (ScalarData (SingleTerm 1 [(FunctionData sym newScalars, 1)]))-applyRef _ (Value (ScalarData fn@(SingleTerm 1 [(Symbol _ symName _, 1)]))) refs = do+      ++ show (length args) ++ ", got " ++ show (length newCASVals)))+  return $ Value $ CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.FunctionData sym newCASVals, 1)]]+applyRef _ (Value (CASData fn@(CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol _ symName _, 1)]]))) refs = do   args <- mapM (\ref -> evalRef ref >>= evalWHNF) refs   mExprs <- mapM (\arg -> case arg of-                            ScalarData _ -> extractScalar arg-                            _            -> throwErrorWithTrace (EgisonBug $ "to use undefined function '" ++ symName ++ "', you have to use ScalarData args")) args-  return (Value (ScalarData (SingleTerm 1 [(makeApplyExpr fn mExprs, 1)])))+                            CASData c -> return c+                            _         -> throwErrorWithTrace (EgisonBug $ "to use undefined function '" ++ symName ++ "', you have to use CASData args")) args+  return $ Value $ CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.makeApplyExpr fn mExprs, 1)]] -- QuoteFunction pattern: ('fact 3) should create Apply1 fact 3 -- The quoted function object is stored in QuoteFunction-applyRef env (Value (ScalarData fn@(SingleTerm 1 [(QuoteFunction funcWHNF, 1)]))) refs = do+applyRef _env (Value (CASData fn@(CASPoly [CASTerm (CASInteger 1) [(CAS.QuoteFunction _funcWHNF, 1)]]))) refs = do   args <- mapM (\ref -> evalRef ref >>= evalWHNF) refs   mExprs <- mapM (\arg -> case arg of-                            ScalarData scalar -> return scalar-                            _                 -> throwErrorWithTrace (EgisonBug $ "to use quoted function, you have to use ScalarData args")) args+                            CASData c -> return c+                            _         -> throwErrorWithTrace (EgisonBug $ "to use quoted function, you have to use CASData args")) args   -- Create Apply1/Apply2/etc with the function object-  return (Value (ScalarData (SingleTerm 1 [(makeApplyExpr fn mExprs, 1)])))+  return $ Value $ CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.makeApplyExpr fn mExprs, 1)]] -- Type class method dispatch: look up implementation based on first argument's type -- Uses Type from Types.hs for dispatch (not String-based typeName) applyRef env (Value (ClassMethodRef clsName methName)) refs = do@@ -944,17 +1099,23 @@         _    -> return MNil     (0, MState e l s b [MAtom (IForallPat p1 p2) m t], MState{ mTrees = trees }) -> do       states <- processMStatesAllDFSForall (msingleton (MState e l (ForallPatContext [] []:s) b [MAtom p1 m t]))-      statess' <- mmap (\(MState e' l' (ForallPatContext ms ts:s') b' []) -> do-                            let mat' = makeTuple ms-                            tgt' <- makeITuple ts-                            processMStatesAllDFSForall (msingleton (MState e' l' (ForallPatContext [] []:s') b' [MAtom p2 tgt' mat']))) states+      statess' <- mmap (\ms_state -> case ms_state of+                            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']))+                            _ -> error "processMState (forall): unexpected MState shape (invariant violation)")+                       states       b <- mAny (\case                    MNil -> return True                    _    -> return False) statess'       if b         then return MNil --        else return MNil-        else do nstatess <- mmap (mmap (\(MState e' l' (ForallPatContext [] []:s') b' []) -> return $ MState e' l' s' b' trees)) statess'+        else do nstatess <- mmap (mmap (\ms_state -> case ms_state of+                                            MState e' l' (ForallPatContext [] []:s') b' [] -> return $ MState e' l' s' b' trees+                                            _ -> error "processMState (forall): unexpected nstate shape (invariant violation)"))+                                  statess'                 mconcat nstatess     _ -> processMState' state  where@@ -1061,7 +1222,7 @@       startNumRef <- newEvaluatedObjectRef $ Value $ toEgison (startNum - 1)       ends'       <- evalExprShallow env' ends       case ends' of-        Value (ScalarData _) -> do -- the case when the end numbers are an integer+        Value (CASData _) -> do -- the case when the end numbers are an integer           endsRef  <- newEvaluatedObjectRef ends'           inners   <- liftIO . newIORef $ Sq.fromList [IElement endsRef]           endsRef' <- liftIO $ newIORef (WHNF (ICollection inners))@@ -1223,26 +1384,68 @@     Nothing      -> throwErrorWithTrace PrimitiveMatchFailure     Just binding -> return binding --- Helper functions to convert internal math types to ScalarData (MathExpr)-polyExprToScalarData :: PolyExpr -> ScalarData-polyExprToScalarData polyExpr = Div polyExpr (Plus [Term 1 []])+-- Helper: Extract function object from CASValue if it contains QuoteFunction+extractFunctionObjectCAS :: CASValue -> WHNFData+extractFunctionObjectCAS (CAS.CASFactor (CAS.QuoteFunction funcWHNF)) = funcWHNF+extractFunctionObjectCAS (CAS.CASPoly [CAS.CASTerm (CAS.CASInteger 1) [(CAS.QuoteFunction funcWHNF, 1)]]) = funcWHNF+extractFunctionObjectCAS cv = Value (CASData cv) -termExprToScalarData :: TermExpr -> ScalarData-termExprToScalarData termExpr = Div (Plus [termExpr]) (Plus [Term 1 []])+-- Helper: Extract numerator from CASValue+getCASNumerator :: CASValue -> CASValue+getCASNumerator (CAS.CASFrac num _) = num+getCASNumerator cv = cv -symbolExprToScalarData :: SymbolExpr -> ScalarData-symbolExprToScalarData symbolExpr = Div (Plus [Term 1 [(symbolExpr, 1)]]) (Plus [Term 1 []])+-- Helper: Extract denominator from CASValue+getCASenominator :: CASValue -> CASValue+getCASenominator (CAS.CASFrac _ den) = den+getCASenominator _ = CAS.CASInteger 1 --- Check if pattern is a pattern variable-isPatternVar :: IPrimitiveDataPattern -> Bool-isPatternVar (PDPatVar _) = True-isPatternVar _            = False+-- Helper: Convert CASValue to list of CASTerms+casToTerms :: CASValue -> [CAS.CASTerm]+casToTerms (CAS.CASPoly terms) = terms+casToTerms (CAS.CASInteger 0) = []+casToTerms (CAS.CASInteger n) = [CAS.CASTerm (CAS.CASInteger n) []]+casToTerms (CAS.CASFactor sym) = [CAS.CASTerm (CAS.CASInteger 1) [(sym, 1)]]+casToTerms cv = [CAS.CASTerm cv []] --- Helper: Extract function object from ScalarData if it contains QuoteFunction-extractFunctionObject :: ScalarData -> WHNFData-extractFunctionObject (SingleTerm 1 [(QuoteFunction funcWHNF, 1)]) = funcWHNF-extractFunctionObject scalarData = Value (ScalarData scalarData)+-- Helper: Convert CAS.SymbolExpr to CASValue (single term with coefficient 1)+symbolToCASValue :: CAS.SymbolExpr -> CASValue+symbolToCASValue sym = CAS.CASPoly [CAS.CASTerm (CAS.CASInteger 1) [(sym, 1)]] +-- Helper: Convert CASTerm to CASValue.+-- For an Integer-coefficient constant term, return the bare CASInteger so+-- downstream user code (e.g. `map`/arithmetic over the term list) sees the+-- canonical numeric form. For non-Integer constants (e.g. CASFrac+-- coefficients in level-4 `Poly (Frac Integer)` polynomials) we must wrap+-- in CASPoly to preserve the `Frac (Plus [Term n xs]) (Plus [Term 1 []])`+-- shape that `term $ $` etc. PDPs in lib/math/expression.egi expect —+-- otherwise extraction of the constant Frac coefficient via `term $a _`+-- silently fails (the bare CASFrac exposes its denom != 1).+termToCASValue :: CAS.CASTerm -> CASValue+termToCASValue (CAS.CASTerm coeff@(CAS.CASInteger _) []) = coeff+termToCASValue t = CAS.CASPoly [t]++-- Helper: Extract SymbolExpr from CASValue if it's a single-symbol single-term polynomial+-- Returns Nothing if not a simple symbol+extractSymbolExpr :: CASValue -> Maybe CAS.SymbolExpr+extractSymbolExpr (CAS.CASFactor sym) = Just sym+extractSymbolExpr (CAS.CASPoly [CAS.CASTerm (CAS.CASInteger 1) [(sym, 1)]]) = Just sym+extractSymbolExpr _ = Nothing++-- Helper: Extract coefficient and monomials from CASValue (expects single-term poly)+extractTerm :: CASValue -> Maybe (CASValue, CAS.Monomial)+extractTerm (CAS.CASFactor sym) = Just (CAS.CASInteger 1, [(sym, 1)])+extractTerm (CAS.CASPoly [CAS.CASTerm coeff mono]) = Just (coeff, mono)+extractTerm (CAS.CASInteger n) = Just (CAS.CASInteger n, [])+extractTerm _ = Nothing++-- Helper: Convert Index CASValue to a CASValue representation+-- We wrap the index expression in InductiveData for pattern matching+indexToCASValue :: Index CASValue -> CASValue+indexToCASValue (Sub cv) = cv  -- For now, just return the inner value+indexToCASValue (Sup cv) = cv+indexToCASValue (User cv) = cv+ primitiveDataPatternMatch :: IPrimitiveDataPattern -> ObjectRef -> MatchM [Binding] primitiveDataPatternMatch PDWildCard _        = return [] primitiveDataPatternMatch (PDPatVar name) ref = return [(name, ref)]@@ -1283,142 +1486,164 @@   case whnf of     Value val | val == evalConstant expr -> return []     _                                    -> matchFail--- ScalarData (MathExpr) primitive patterns-primitiveDataPatternMatch (PDDivPat patNum patDen) ref = do+-- CASValue primitive patterns+-- All patterns work directly with CASData CASValue, no intermediate types needed+primitiveDataPatternMatch (PDFracPat patNum patDen) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (ScalarData (Div num den)) -> do-      -- Pattern variable の場合は PolyExpr -> ScalarData に変換-      let numVal = if isPatternVar patNum -                   then Value (ScalarData (polyExprToScalarData num))-                   else Value (PolyExprData num)-      let denVal = if isPatternVar patDen-                   then Value (ScalarData (polyExprToScalarData den))-                   else Value (PolyExprData den)-      numRef <- lift $ newEvaluatedObjectRef numVal-      denRef <- lift $ newEvaluatedObjectRef denVal+    Value (CASData cv) -> do+      let num = getCASNumerator cv+          den = getCASenominator cv+      -- Always return CASData for both numerator and denominator+      numRef <- lift $ newEvaluatedObjectRef (Value (CASData num))+      denRef <- lift $ newEvaluatedObjectRef (Value (CASData den))       (++) <$> primitiveDataPatternMatch patNum numRef            <*> primitiveDataPatternMatch patDen denRef     _ -> matchFail primitiveDataPatternMatch (PDPlusPat patTerms) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (PolyExprData (Plus terms)) -> do-      -- Pattern variable の場合は [TermExpr] -> [ScalarData] に変換-      let termsCol = if isPatternVar patTerms-                     then Value $ Collection $ Sq.fromList $ map (ScalarData . termExprToScalarData) terms-                     else Value $ Collection $ Sq.fromList $ map TermExprData terms+    Value (CASData cv) -> do+      -- Extract terms from CASValue and convert each to CASData+      let terms = casToTerms cv+      let termsCol = Value $ Collection $ Sq.fromList $+                     map (\t -> CASData (termToCASValue t)) terms       termsRef <- lift $ newEvaluatedObjectRef termsCol       primitiveDataPatternMatch patTerms termsRef     _ -> matchFail primitiveDataPatternMatch (PDTermPat patCoeff patMonomials) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (TermExprData (Term coeff monomials)) -> do-      coeffRef <- lift $ newEvaluatedObjectRef (Value (toEgison coeff))-      -- Pattern variable の場合は [(SymbolExpr, Integer)] -> [(ScalarData, Integer)] に変換-      let monomialsCol = if isPatternVar patMonomials-                         then Value $ Collection $ Sq.fromList $ map (\(sym, exp) -> Tuple [ScalarData (symbolExprToScalarData sym), toEgison exp]) monomials-                         else Value $ Collection $ Sq.fromList $ map (\(sym, exp) -> Tuple [SymbolExprData sym, toEgison exp]) monomials-      monomialsRef <- lift $ newEvaluatedObjectRef monomialsCol-      (++) <$> primitiveDataPatternMatch patCoeff coeffRef-           <*> primitiveDataPatternMatch patMonomials monomialsRef+    Value (CASData cv) -> do+      -- Extract term from CASValue (expects single-term polynomial)+      case extractTerm cv of+        Just (coeff, monomials) -> do+          coeffRef <- lift $ newEvaluatedObjectRef (Value (CASData coeff))+          -- Convert [(SymbolExpr, Integer)] -> [(CASData, Integer)]+          let monomialsCol = Value $ Collection $ Sq.fromList $+                             map (\(sym, expo) -> Tuple [CASData (symbolToCASValue sym), toEgison expo]) monomials+          monomialsRef <- lift $ newEvaluatedObjectRef monomialsCol+          (++) <$> primitiveDataPatternMatch patCoeff coeffRef+               <*> primitiveDataPatternMatch patMonomials monomialsRef+        Nothing -> matchFail     _ -> matchFail primitiveDataPatternMatch (PDSymbolPat patName patIndices) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (SymbolExprData (Symbol _ name indices)) -> do-      nameRef <- lift $ newEvaluatedObjectRef (Value (String (T.pack name)))-      -- [Index ScalarData]をCollectionに変換-      let indicesCol = Value $ Collection $ Sq.fromList $ map IndexExprData indices-      indicesRef <- lift $ newEvaluatedObjectRef indicesCol-      (++) <$> primitiveDataPatternMatch patName nameRef-           <*> primitiveDataPatternMatch patIndices indicesRef+    Value (CASData cv) -> do+      -- Extract symbol from CASValue+      case extractSymbolExpr cv of+        Just (CAS.Symbol _ name indices) -> do+          nameRef <- lift $ newEvaluatedObjectRef (Value (String (T.pack name)))+          -- [Index CASValue] -> Collection of CASData (wrapped indices)+          let indicesCol = Value $ Collection $ Sq.fromList $ map (CASData . indexToCASValue) indices+          indicesRef <- lift $ newEvaluatedObjectRef indicesCol+          (++) <$> primitiveDataPatternMatch patName nameRef+               <*> primitiveDataPatternMatch patIndices indicesRef+        _ -> matchFail     _ -> matchFail primitiveDataPatternMatch (PDApply1Pat patFn patArg) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (SymbolExprData (Apply1 fn arg)) -> do-      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)-      argRef <- lift $ newEvaluatedObjectRef (Value (ScalarData arg))-      (++) <$> primitiveDataPatternMatch patFn fnRef-           <*> primitiveDataPatternMatch patArg argRef+    Value (CASData cv) -> do+      case extractSymbolExpr cv of+        Just (CAS.Apply1 fn arg) -> do+          fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObjectCAS fn)+          argRef <- lift $ newEvaluatedObjectRef (Value (CASData arg))+          (++) <$> primitiveDataPatternMatch patFn fnRef+               <*> primitiveDataPatternMatch patArg argRef+        _ -> matchFail     _ -> matchFail primitiveDataPatternMatch (PDApply2Pat patFn patArg1 patArg2) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (SymbolExprData (Apply2 fn arg1 arg2)) -> do-      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)-      arg1Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg1))-      arg2Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg2))-      (++) <$> primitiveDataPatternMatch patFn fnRef-           <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref-                     <*> primitiveDataPatternMatch patArg2 arg2Ref)+    Value (CASData cv) -> do+      case extractSymbolExpr cv of+        Just (CAS.Apply2 fn arg1 arg2) -> do+          fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObjectCAS fn)+          arg1Ref <- lift $ newEvaluatedObjectRef (Value (CASData arg1))+          arg2Ref <- lift $ newEvaluatedObjectRef (Value (CASData arg2))+          (++) <$> primitiveDataPatternMatch patFn fnRef+               <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref+                         <*> primitiveDataPatternMatch patArg2 arg2Ref)+        _ -> matchFail     _ -> matchFail primitiveDataPatternMatch (PDApply3Pat patFn patArg1 patArg2 patArg3) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (SymbolExprData (Apply3 fn arg1 arg2 arg3)) -> do-      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)-      arg1Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg1))-      arg2Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg2))-      arg3Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg3))-      (++) <$> primitiveDataPatternMatch patFn fnRef-           <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref-                     <*> ((++) <$> primitiveDataPatternMatch patArg2 arg2Ref-                               <*> primitiveDataPatternMatch patArg3 arg3Ref))+    Value (CASData cv) -> do+      case extractSymbolExpr cv of+        Just (CAS.Apply3 fn arg1 arg2 arg3) -> do+          fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObjectCAS fn)+          arg1Ref <- lift $ newEvaluatedObjectRef (Value (CASData arg1))+          arg2Ref <- lift $ newEvaluatedObjectRef (Value (CASData arg2))+          arg3Ref <- lift $ newEvaluatedObjectRef (Value (CASData arg3))+          (++) <$> primitiveDataPatternMatch patFn fnRef+               <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref+                         <*> ((++) <$> primitiveDataPatternMatch patArg2 arg2Ref+                                   <*> primitiveDataPatternMatch patArg3 arg3Ref))+        _ -> matchFail     _ -> matchFail primitiveDataPatternMatch (PDApply4Pat patFn patArg1 patArg2 patArg3 patArg4) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (SymbolExprData (Apply4 fn arg1 arg2 arg3 arg4)) -> do-      fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObject fn)-      arg1Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg1))-      arg2Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg2))-      arg3Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg3))-      arg4Ref <- lift $ newEvaluatedObjectRef (Value (ScalarData arg4))-      (++) <$> primitiveDataPatternMatch patFn fnRef-           <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref-                     <*> ((++) <$> primitiveDataPatternMatch patArg2 arg2Ref-                               <*> ((++) <$> primitiveDataPatternMatch patArg3 arg3Ref-                                         <*> primitiveDataPatternMatch patArg4 arg4Ref)))+    Value (CASData cv) -> do+      case extractSymbolExpr cv of+        Just (CAS.Apply4 fn arg1 arg2 arg3 arg4) -> do+          fnRef <- lift $ newEvaluatedObjectRef (extractFunctionObjectCAS fn)+          arg1Ref <- lift $ newEvaluatedObjectRef (Value (CASData arg1))+          arg2Ref <- lift $ newEvaluatedObjectRef (Value (CASData arg2))+          arg3Ref <- lift $ newEvaluatedObjectRef (Value (CASData arg3))+          arg4Ref <- lift $ newEvaluatedObjectRef (Value (CASData arg4))+          (++) <$> primitiveDataPatternMatch patFn fnRef+               <*> ((++) <$> primitiveDataPatternMatch patArg1 arg1Ref+                         <*> ((++) <$> primitiveDataPatternMatch patArg2 arg2Ref+                                   <*> ((++) <$> primitiveDataPatternMatch patArg3 arg3Ref+                                             <*> primitiveDataPatternMatch patArg4 arg4Ref)))+        _ -> matchFail     _ -> matchFail primitiveDataPatternMatch (PDQuotePat patExpr) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (SymbolExprData (Quote expr)) -> do-      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))-      primitiveDataPatternMatch patExpr exprRef+    Value (CASData cv) -> do+      case extractSymbolExpr cv of+        Just (CAS.Quote expr) -> do+          exprRef <- lift $ newEvaluatedObjectRef (Value (CASData expr))+          primitiveDataPatternMatch patExpr exprRef+        _ -> matchFail     _ -> matchFail primitiveDataPatternMatch (PDFunctionPat patName patArgs) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (SymbolExprData (FunctionData name args)) -> do-      nameRef <- lift $ newEvaluatedObjectRef (Value (ScalarData name))-      let argsCol = Value $ Collection $ Sq.fromList $ map ScalarData args-      argsRef <- lift $ newEvaluatedObjectRef argsCol-      (++) <$> primitiveDataPatternMatch patName nameRef-           <*> primitiveDataPatternMatch patArgs argsRef+    Value (CASData cv) -> do+      case extractSymbolExpr cv of+        Just (CAS.FunctionData name args) -> do+          nameRef <- lift $ newEvaluatedObjectRef (Value (CASData name))+          let argsCol = Value $ Collection $ Sq.fromList $ map CASData args+          argsRef <- lift $ newEvaluatedObjectRef argsCol+          (++) <$> primitiveDataPatternMatch patName nameRef+               <*> primitiveDataPatternMatch patArgs argsRef+        _ -> matchFail     _ -> matchFail primitiveDataPatternMatch (PDSubPat patExpr) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (IndexExprData (Sub expr)) -> do-      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))+    Value (CASIndexData (Sub expr)) -> do+      exprRef <- lift $ newEvaluatedObjectRef (Value (CASData expr))       primitiveDataPatternMatch patExpr exprRef     _ -> matchFail primitiveDataPatternMatch (PDSupPat patExpr) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (IndexExprData (Sup expr)) -> do-      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))+    Value (CASIndexData (Sup expr)) -> do+      exprRef <- lift $ newEvaluatedObjectRef (Value (CASData expr))       primitiveDataPatternMatch patExpr exprRef     _ -> matchFail primitiveDataPatternMatch (PDUserPat patExpr) ref = do   whnf <- lift $ evalRef ref   case whnf of-    Value (IndexExprData (User expr)) -> do-      exprRef <- lift $ newEvaluatedObjectRef (Value (ScalarData expr))+    Value (CASIndexData (User expr)) -> do+      exprRef <- lift $ newEvaluatedObjectRef (Value (CASData expr))       primitiveDataPatternMatch patExpr exprRef     _ -> matchFail @@ -1447,8 +1672,11 @@   xs' <- mapM newEvaluatedObjectRef xs   return $ ITensor (Tensor s (V.fromList xs') []) -newITensor :: Shape -> [ObjectRef] -> WHNFData-newITensor s refs = ITensor (Tensor s (V.fromList refs) [])+-- A rank-zero tensor is its sole scalar component.  Do not use the component+-- count alone here: shapes [0] and [1] are still rank-one tensors.+newITensor :: Shape -> [ObjectRef] -> EvalM WHNFData+newITensor [] [ref] = evalRef ref+newITensor s refs = return $ ITensor (Tensor s (V.fromList refs) [])  -- Refer the specified tensor index with potential overriding of the index. refTensorWithOverride :: TensorComponent a b => Bool -> [Index EgisonValue] -> Tensor b -> EvalM a@@ -1472,4 +1700,3 @@  makeBindings' :: [String] -> [ObjectRef] -> [Binding] makeBindings' xs = zip (map stringToVar xs)-

@@ -20,14 +20,17 @@     , EgisonData (..)     , Tensor (..)     , Shape-    -- * Scalar-    , symbolScalarData-    , symbolScalarData'+    -- * Symbol helpers     , getSymId-    , getSymName-    , mathExprToEgison-    , egisonToScalarData-    , extractScalar+    -- * CAS types and helpers+    , CASValue(..)+    , CASTerm(..)+    , extractCASValue+    , symbolCASData+    , quoteCASData+    , quoteFunctionCASData+    , functionCASData+    , applyCASData     -- * Internal data     , Object (..)     , ObjectRef@@ -75,7 +78,7 @@ import qualified Data.Vector                      as V  import           Data.List                        (intercalate, sortOn)-import           Data.Text                        (Text, pack, unpack)+import           Data.Text                        (Text) import           Text.Show.Unicode                (ushow)  import           Data.Ratio@@ -85,6 +88,7 @@ import           Language.Egison.EvalState import           Language.Egison.IExpr import           Language.Egison.Math+import qualified Language.Egison.Math.CAS as CAS import           Language.Egison.RState  --@@ -96,7 +100,7 @@   | Char Char   | String Text   | Bool Bool-  | ScalarData ScalarData+  | CASData CASValue  -- Computer algebra system type (CAS)   | TensorData (Tensor EgisonValue)   | Float Double   | InductiveData String [EgisonValue]@@ -121,11 +125,8 @@   -- ClassMethodRef className methodName   -- Looks up implementation from the instance environment in EvalState   | ClassMethodRef String String-  -- MathExpr internal types for direct pattern matching-  | PolyExprData PolyExpr-  | TermExprData TermExpr-  | SymbolExprData SymbolExpr-  | IndexExprData (Index ScalarData)+  -- CAS internal type for index pattern matching (subscript, superscript, user)+  | CASIndexData (Index CASValue)  type Matcher = EgisonValue @@ -149,161 +150,39 @@ type Shape = [Integer]  ----- Scalars+-- CAS Value Helpers -- -symbolScalarData :: String -> String -> EgisonValue-symbolScalarData id name = ScalarData (SingleTerm 1 [(Symbol id name [], 1)])--symbolScalarData' :: String -> ScalarData-symbolScalarData' name = SingleTerm 1 [(Symbol "" name [], 1)]-+-- | Extract symbol ID from a CAS symbol value getSymId :: EgisonValue -> String-getSymId (ScalarData (SingleTerm 1 [(Symbol id _ _, _)])) = 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 (Apply1 fn a1, n) = Tuple [InductiveData "Apply1" [ScalarData fn, ScalarData a1], toEgison n]-symbolExprToEgison (Apply2 fn a1 a2, n) = Tuple [InductiveData "Apply2" [ScalarData fn, ScalarData a1, ScalarData a2], toEgison n]-symbolExprToEgison (Apply3 fn a1 a2 a3, n) = Tuple [InductiveData "Apply3" [ScalarData fn, ScalarData a1, ScalarData a2, ScalarData a3], toEgison n]-symbolExprToEgison (Apply4 fn a1 a2 a3 a4, n) = Tuple [InductiveData "Apply4" [ScalarData fn, ScalarData a1, ScalarData a2, ScalarData a3, ScalarData a4], toEgison n]-symbolExprToEgison (Quote mExpr, n) = Tuple [InductiveData "Quote" [mathExprToEgison mExpr], toEgison n]-symbolExprToEgison (QuoteFunction (Value funcVal), n) = Tuple [InductiveData "QuoteFunction" [funcVal], toEgison n]-symbolExprToEgison (QuoteFunction whnf, n) = error $ "symbolExprToEgison: QuoteFunction with non-Value WHNF: " ++ show whnf-symbolExprToEgison (FunctionData name args, n) =-  Tuple [InductiveData "Function" [ScalarData name, Collection (Sq.fromList (map ScalarData args))], toEgison n]--scalarIndexToEgison :: Index ScalarData -> EgisonValue-scalarIndexToEgison (Sup k)  = InductiveData "Sup"  [ScalarData k]-scalarIndexToEgison (Sub k)  = InductiveData "Sub"  [ScalarData k]-scalarIndexToEgison (User k) = InductiveData "User" [ScalarData k]---- Direct index conversion for primitive pattern matching-indexToEgison :: Index ScalarData -> EgisonValue-indexToEgison = IndexExprData---- Implementation of 'toMathExpr' (Primitive function)-egisonToScalarData :: EgisonValue -> EvalM ScalarData-egisonToScalarData (InductiveData "Div" [p1, p2]) = Div <$> egisonToPolyExpr p1 <*> egisonToPolyExpr p2-egisonToScalarData p1@(InductiveData "Plus" _) = Div <$> egisonToPolyExpr p1 <*> return (Plus [Term 1 []])-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 "Apply1" _) = do-  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])-  return $ SingleTerm 1 [s1']-egisonToScalarData s1@(InductiveData "Apply2" _) = do-  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])-  return $ SingleTerm 1 [s1']-egisonToScalarData s1@(InductiveData "Apply3" _) = do-  s1' <- egisonToSymbolExpr (Tuple [s1, toEgison (1 :: Integer)])-  return $ SingleTerm 1 [s1']-egisonToScalarData s1@(InductiveData "Apply4" _) = 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 "QuoteFunction" _) = 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 (ScalarData s) = return s-egisonToScalarData val = throwErrorWithTrace (TypeMismatch "math expression" (Value val))--egisonToPolyExpr :: EgisonValue -> EvalM PolyExpr-egisonToPolyExpr (InductiveData "Plus" [Collection ts]) = Plus <$> mapM egisonToTermExpr (toList ts)-egisonToPolyExpr val                                    = throwErrorWithTrace (TypeMismatch "math poly expression" (Value val))+getSymId val = case val of+  CASData (CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol symId _ _, _)]]) -> symId+  _ -> error "getSymId: not a symbol" -egisonToTermExpr :: EgisonValue -> EvalM TermExpr-egisonToTermExpr (InductiveData "Term" [n, Collection ts]) = Term <$> fromEgison n <*> mapM egisonToSymbolExpr (toList ts)-egisonToTermExpr val                                       = throwErrorWithTrace (TypeMismatch "math term expression" (Value val))+-- | Create a symbol CASValue+symbolCASData :: String -> String -> EgisonValue+symbolCASData symId name = CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol symId name [], 1)]] -egisonToSymbolExpr :: EgisonValue -> EvalM (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 "Apply1" [fn, a1], n]) = do-  fn' <- extractScalar fn-  a1' <- egisonToScalarData a1-  n' <- fromEgison n-  return (Apply1 fn' a1', n')-egisonToSymbolExpr (Tuple [InductiveData "Apply2" [fn, a1, a2], n]) = do-  fn' <- extractScalar fn-  a1' <- egisonToScalarData a1-  a2' <- egisonToScalarData a2-  n' <- fromEgison n-  return (Apply2 fn' a1' a2', n')-egisonToSymbolExpr (Tuple [InductiveData "Apply3" [fn, a1, a2, a3], n]) = do-  fn' <- extractScalar fn-  a1' <- egisonToScalarData a1-  a2' <- egisonToScalarData a2-  a3' <- egisonToScalarData a3-  n' <- fromEgison n-  return (Apply3 fn' a1' a2' a3', n')-egisonToSymbolExpr (Tuple [InductiveData "Apply4" [fn, a1, a2, a3, a4], n]) = do-  fn' <- extractScalar fn-  a1' <- egisonToScalarData a1-  a2' <- egisonToScalarData a2-  a3' <- egisonToScalarData a3-  a4' <- egisonToScalarData a4-  n' <- fromEgison n-  return (Apply4 fn' a1' a2' a3' a4', n')-egisonToSymbolExpr (Tuple [InductiveData "Quote" [mExpr], n]) = do-  mExpr' <- egisonToScalarData mExpr-  n' <- fromEgison n-  return (Quote mExpr', n')-egisonToSymbolExpr (Tuple [InductiveData "QuoteFunction" [funcVal], n]) = do-  n' <- fromEgison n-  return (QuoteFunction (Value funcVal), n')-egisonToSymbolExpr (Tuple [InductiveData "Function" [name, Collection args], n]) = do-  name' <- extractScalar name-  args' <- mapM extractScalar (toList args)-  n' <- fromEgison n-  return (FunctionData name' args', n')-egisonToSymbolExpr val = throwErrorWithTrace (TypeMismatch "math symbol expression" (Value val))+-- | Create a Quote CASValue+quoteCASData :: CASValue -> EgisonValue+quoteCASData cv = CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.Quote cv, 1)]] -egisonToScalarIndex :: EgisonValue -> EvalM (Index ScalarData)-egisonToScalarIndex j = case j of-  InductiveData "Sup"  [ScalarData k] -> return (Sup k)-  InductiveData "Sub"  [ScalarData k] -> return (Sub k)-  InductiveData "User" [ScalarData k] -> return (User k)-  _                                   -> throwErrorWithTrace (TypeMismatch "math symbol expression" (Value j))+-- | Create a QuoteFunction CASValue+quoteFunctionCASData :: WHNFData -> EgisonValue+quoteFunctionCASData whnf = CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.QuoteFunction whnf, 1)]] ------ ExtractScalar---+-- | Create a FunctionData CASValue+functionCASData :: CASValue -> [CASValue] -> EgisonValue+functionCASData sym args = CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.FunctionData sym args, 1)]] -extractScalar :: EgisonValue -> EvalM ScalarData-extractScalar (ScalarData mExpr) = return mExpr-extractScalar val                = throwErrorWithTrace (TypeMismatch "math expression" (Value val))+-- | Create an Apply CASValue (Apply1-4 based on argument count)+applyCASData :: CASValue -> [CASValue] -> EgisonValue+applyCASData fn args = CASData $ CASPoly [CASTerm (CASInteger 1) [(CAS.makeApplyExpr fn args, 1)]] -extractString :: EgisonValue -> EvalM String-extractString (String t) = return (unpack t)-extractString val        = throwErrorWithTrace (TypeMismatch "string" (Value val))+-- | Extract CASValue from EgisonValue+extractCASValue :: EgisonValue -> EvalM CASValue+extractCASValue (CASData cv) = return cv+extractCASValue val          = throwErrorWithTrace (TypeMismatch "math expression" (Value val))  -- New-syntax version of EgisonValue pretty printer. -- TODO(momohatt): Don't make it a show instance of EgisonValue.@@ -312,7 +191,7 @@   show (String str) = ushow str   show (Bool True) = "True"   show (Bool False) = "False"-  show (ScalarData mExpr) = show mExpr+  show (CASData cv) = prettyCAS cv   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@@ -346,28 +225,23 @@   show Undefined = "undefined"   show World = "#<world>"   show (ClassMethodRef clsName methName) = "#<class-method " ++ clsName ++ "." ++ methName ++ ">"-  -- MathExpr internal types-  show (PolyExprData polyExpr) = show polyExpr-  show (TermExprData termExpr) = show termExpr-  show (SymbolExprData symbolExpr) = show symbolExpr-  show (IndexExprData indexExpr) = show indexExpr+  -- CAS internal type for index pattern matching+  show (CASIndexData idx) = show idx  -- 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 m)       = isAtom m-isAtomic (PolyExprData _)     = False-isAtomic (TermExprData _)     = False-isAtomic (SymbolExprData _)   = False-isAtomic (IndexExprData _)    = False+isAtomic (CASData cv)         = casIsAtom cv+-- CAS internal type for index pattern matching+isAtomic (CASIndexData _)     = 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+  (CASData x) == (CASData y)                                       = CAS.casNormalize x == CAS.casNormalize y  -- Normalize before comparing   (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'@@ -376,11 +250,8 @@   (IntHash vals) == (IntHash vals')                                = vals == vals'   (CharHash vals) == (CharHash vals')                              = vals == vals'   (StrHash vals) == (StrHash vals')                                = vals == vals'-  -- MathExpr internal types-  (PolyExprData p) == (PolyExprData p')                            = p == p'-  (TermExprData t) == (TermExprData t')                            = t == t'-  (SymbolExprData s) == (SymbolExprData s')                        = s == s'-  (IndexExprData i) == (IndexExprData i')                          = i == i'+  -- CAS internal types+  (CASIndexData i) == (CASIndexData i')                            = i == i'   -- Temporary: searching a better solution   (Func (Just name1) _ _ _) == (Func (Just name2) _ _ _)           = name1 == name2   _ == _                                                           = False@@ -408,17 +279,35 @@   fromEgison val      = throwErrorWithTrace (TypeMismatch "bool" (Value val))  instance EgisonData Integer where-  toEgison 0 = ScalarData (Div (Plus []) (Plus [Term 1 []]))-  toEgison i = ScalarData (SingleTerm i [])-  fromEgison (ScalarData (Div (Plus []) (Plus [Term 1 []]))) = return 0-  fromEgison (ScalarData (SingleTerm x []))                  = return x-  fromEgison val                                             = throwErrorWithTrace (TypeMismatch "integer" (Value val))+  toEgison 0 = CASData (CASInteger 0)+  toEgison i = CASData (CASInteger i)+  fromEgison val = case val of+    CASData cv -> case extractCASInteger cv of+      Just n  -> return n+      Nothing -> throwErrorWithTrace (TypeMismatch "integer" (Value val))+    _ -> throwErrorWithTrace (TypeMismatch "integer" (Value val)) +-- | Extract an Integer from a CASValue, handling divisions that simplify to integers+extractCASInteger :: CASValue -> Maybe Integer+extractCASInteger cv = case cv of+  CASInteger n -> Just n+  CASPoly [] -> Just 0+  CASPoly [CASTerm coef []] -> extractCASInteger coef+  CASFrac num den -> do+    n <- extractCASInteger num+    d <- extractCASInteger den+    if d /= 0 && n `mod` d == 0 then Just (n `div` d) else Nothing+  _ -> Nothing+ 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                                                      = throwErrorWithTrace (TypeMismatch "rational" (Value val))+  toEgison r = CASData $ CAS.casNormalize (CAS.CASFrac (CAS.CASInteger (numerator r)) (CAS.CASInteger (denominator r)))+  fromEgison val = case val of+    CASData (CASInteger 0)                  -> return 0+    CASData (CASPoly [])                    -> return 0+    CASData (CASInteger x)                  -> return (x % 1)+    CASData (CASPoly [CASTerm (CASInteger x) []]) -> return (x % 1)+    CASData (CASFrac (CASPoly [CASTerm (CASInteger x) []]) (CASPoly [CASTerm (CASInteger y) []])) -> return (x % y)+    _                                       -> throwErrorWithTrace (TypeMismatch "rational" (Value val))  instance EgisonData Double where   toEgison f = Float f@@ -533,21 +422,21 @@  -- | Environment: list of layers (for scoping) plus optional index context, -- plus a separate store for pattern functions.-data Env = Env [EnvLayer] (Maybe (String, [Index (Maybe ScalarData)])) PatFuncEnv+data Env = Env [EnvLayer] (Maybe (String, [Index (Maybe CASValue)])) PatFuncEnv  type Binding = (Var, ObjectRef)  instance {-# OVERLAPPING #-} Show (Index EgisonValue) where   show (Sup i) = case i of-    ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "~[" ++ show i ++ "]"-    _                                                 -> "~" ++ show i+    CASData (CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol _ _ (_:_), 1)]]) -> "~[" ++ show i ++ "]"+    _ -> "~" ++ show i   show (Sub i) = case i of-    ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]"-    _                                                 -> "_" ++ show i+    CASData (CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol _ _ (_:_), 1)]]) -> "_[" ++ show i ++ "]"+    _ -> "_" ++ show i   show (SupSub i) = "~_" ++ show i   show (User i) = case i of-    ScalarData (SingleTerm 1 [(Symbol _ _ (_:_), 1)]) -> "_[" ++ show i ++ "]"-    _                                                 -> "|" ++ show i+    CASData (CASPoly [CASTerm (CASInteger 1) [(CAS.Symbol _ _ (_:_), 1)]]) -> "_[" ++ show i ++ "]"+    _ -> "|" ++ show i   show (DF i j) = "_df-" ++ show i ++ "-" ++ show j  nullEnv :: Env

@@ -95,13 +95,13 @@ showIndexValues :: [Index EgisonValue] -> [String] showIndexValues = map showIndexValue   where-    showIndexValue (Sub val) = "_<val>"-    showIndexValue (Sup val) = "~<val>"-    showIndexValue (SupSub val) = "~_<val>"-    showIndexValue (User val) = "@<val>"-    showIndexValue (DF id n) = "_df-" ++ show id ++ "-" ++ show n-    showIndexValue (MultiSub val s _) = "_(..." ++ show s ++ "...)"-    showIndexValue (MultiSup val s _) = "~(..." ++ show s ++ "...)"+    showIndexValue (Sub _val) = "_<val>"+    showIndexValue (Sup _val) = "~<val>"+    showIndexValue (SupSub _val) = "~_<val>"+    showIndexValue (User _val) = "@<val>"+    showIndexValue (DF idn n) = "_df-" ++ show idn ++ "-" ++ show n+    showIndexValue (MultiSub _val s _) = "_(..." ++ show s ++ "...)"+    showIndexValue (MultiSup _val s _) = "~(..." ++ show s ++ "...)"  pmIndices :: [Index (Maybe Var)] -> [Index EgisonValue] -> EvalM [Binding] pmIndices [] [] = return []@@ -110,25 +110,33 @@   let l = fromIntegral (length vs1)   eRef <- newEvaluatedObjectRef (Value (toEgison l))   let hash = (IIntHash HL.empty)-  hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash (zip [s..(s + l - 1)] (map (\(Sub v) -> Value v) vs1)) +  hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash+                (zip [s..(s + l - 1)]+                     (map subValue vs1))   aRef <- newEvaluatedObjectRef hash   bs <- pmIndices xs vs2   return ((a, aRef) : (e, eRef) : bs)  where   isSub (Sub _) = True   isSub _       = False+  subValue (Sub v) = Value v+  subValue idx     = error ("pmIndices: expected Sub index, got: " ++ show idx) pmIndices (MultiSup (Just a) s (Just e):xs) vs = do   let (vs1, vs2) = span isSup vs   let l = fromIntegral (length vs1)   eRef <- newEvaluatedObjectRef (Value (toEgison l))   let hash = (IIntHash HL.empty)-  hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash (zip [s..(s + l - 1)] (map (\(Sup v) -> Value v) vs1)) +  hash <- foldM (\hash (i, v) -> updateHash [i] v hash) hash+                (zip [s..(s + l - 1)]+                     (map supValue vs1))   aRef <- newEvaluatedObjectRef hash   bs <- pmIndices xs vs2   return ((a, aRef) : (e, eRef) : bs)  where   isSup (Sup _) = True   isSup _       = False+  supValue (Sup v) = Value v+  supValue idx     = error ("pmIndices: expected Sup index, got: " ++ show idx)  pmIndices (x:xs) (v:vs) = do   bs <- pmIndex x v@@ -143,6 +151,17 @@ pmIndex (Sup (Just var)) (Sup val) = do   ref <- newEvaluatedObjectRef (Value val)   return [(var, ref)]+-- `def f_i_j := ...` desugars (Desugar.hs `desugarDefineWithIndices`) so+-- the function's stored Var indices are *kind-only* (`Sub Nothing` /+-- `Sup Nothing`) — the actual index names are bound separately via+-- `withSymbols` + `transpose` inside the body. When we apply `f_a_b`,+-- the access values come in here and just need to match the index kind;+-- there is no name to bind. Without these clauses every tensor function+-- defined with explicit index names (e.g. the WCS invariant computation+-- in `sample/math/geometry/thurston.egi`) raises+-- "Inconsistent tensor index: [_?] vs [_<val>]".+pmIndex (Sub Nothing) (Sub _) = return []+pmIndex (Sup Nothing) (Sup _) = return [] pmIndex expected actual = throwErrorWithTrace $ InconsistentTensorIndex (showIndexPattern [expected]) (showIndexValues [actual])  updateHash :: [Integer] -> WHNFData -> WHNFData -> EvalM WHNFData

@@ -15,7 +15,7 @@    Design Note (design/implementation.md): Pattern matching itself is NOT desugared here. Match expressions (IMatchExpr, -IMatchAllExpr) are kept as-is and processed during evaluation (Phase 10).+IMatchAllExpr) are kept as-is and processed during evaluation (Phase 9). This allows Egison's sophisticated pattern matching to be implemented in the evaluator. -} @@ -29,15 +29,19 @@ import           Control.Monad.Except   (throwError) import           Data.Char              (toUpper) import           Data.Foldable          (foldrM)-import           Data.List              (union)+import           Data.List              (nubBy, union) import           Data.Text              (pack)  import           Language.Egison.AST import           Language.Egison.Data import           Language.Egison.IExpr import           Language.Egison.RState-import           Language.Egison.Type.Types (sanitizeMethodName, typeToName, typeConstructorName, -                                             typeExprToType, capitalizeFirst, lowerFirst, TyVar(..))+import           Language.Egison.EvalState  (MonadEval(..))+import           Language.Egison.Type.Env   (lookupClass, ClassInfo(..))+import           Language.Egison.Type.Types (sanitizeMethodName, typeToName,+                                             typeExprToType, expandTypeAliases,+                                             capitalizeFirst, lowerFirst, TyVar(..),+                                             Type(TInt, TMathValue))   desugarTopExpr :: TopExpr -> EvalM (Maybe ITopExpr)@@ -49,17 +53,22 @@   -- Type information is used for type checking, but the runtime representation is the same   -- Note: Constraints are preserved in the type scheme (by EnvBuilder),   -- and dictionary passing is handled in TypeClassExpand phase+  --+  -- (Auto-coerce elaboration was tried but reverted: wrapping `e` in+  -- `coerce` breaks inner typeclass dispatch when `e` is itself a method+  -- call needing return-type context — e.g. `def f : Frac Integer := embed 5`+  -- becomes `coerce (embed 5)`, leaving `embed`'s return type ambiguous.+  -- After tower fix + Term widening, runtime forms are already canonical+  -- in most cases, so explicit `coerce` is rarely needed.)   let name = typedVarName typedVwi       indices = typedVarIndices typedVwi       params = typedVarParams typedVwi       vwi = VarWithIndices name indices-  -- If there are typed parameters, wrap the body in a lambda   case params of     [] -> do       (var, iexpr) <- desugarDefineWithIndices vwi expr       return . Just $ IDefine var iexpr     _  -> do-      -- Create lambda arguments from typed parameters       let argPatterns = map typedParamToArgPattern params           lambdaExpr = LambdaExpr argPatterns expr       (var, iexpr) <- desugarDefineWithIndices vwi lambdaExpr@@ -135,17 +144,23 @@   if null instTypes     then return Nothing     else do-      -- Use type constructor name only (without type parameters)-      -- e.g., "Collection" not "Collectiona" for [a]-      let instTypeName = typeConstructorName (typeExprToType (head instTypes))+      -- Multi-param-friendly: concatenate type names of ALL instance types so+      -- two instances of the same class with different type-tuples get+      -- distinct dictionary names. Use `typeToName` (full type, including+      -- inner parameters) rather than `typeConstructorName` (outer only) so+      -- that e.g. `Coerce (Frac Integer) Integer` and+      -- `Coerce (Frac (Poly Integer [..])) Integer` get distinct names.+      -- cas-type aliases are expanded first so the generated names agree+      -- with EnvBuilder's registerInstanceMethods (Phase alpha).+      aliasEnv <- getCasTypeAliasEnv+      let instTypeNames = map (typeToName . expandTypeAliases aliasEnv . typeExprToType) instTypes+          instTypeName  = concat instTypeNames       -- Generate individual method definitions with constraint parameters       methodDefs <- mapM (desugarInstanceMethod constraints classNm instTypeName) methods-      -- Generate dictionary definition (with constraints if any)-      let dictDef = makeDictDef constraints classNm instTypeName methods-      -- Return all definitions-      case methodDefs of-        []  -> return Nothing-        _   -> return $ Just $ IDefineMany (dictDef : methodDefs)+      -- Generate dictionary definition with superclass references+      dictDef <- makeDictDef classNm instTypeName methods+      -- Always generate the dictionary (even for marker classes with no methods)+      return $ Just $ IDefineMany (dictDef : methodDefs)   where     desugarInstanceMethod :: [ConstraintExpr] -> String -> String -> InstanceMethod -> EvalM (Var, IExpr)     desugarInstanceMethod _constrs clsNm typNm (InstanceMethod methName params body) = do@@ -165,45 +180,59 @@       iexpr <- desugar lambdaExpr       return (var, iexpr)     -    makeDictDef :: [ConstraintExpr] -> String -> String -> [InstanceMethod] -> (Var, IExpr)-    makeDictDef _constrs clsNm typNm meths =+    makeDictDef :: String -> String -> [InstanceMethod] -> EvalM (Var, IExpr)+    makeDictDef clsNm typNm meths = do       let dictName = lowerFirst clsNm ++ typNm  -- e.g., "eqCollection"           dictVar = stringToVar dictName-          -          -- For nested instances (with constraints), the dictionary becomes a function-          -- that takes dictionary parameters and returns a hash.-          -- e.g., for instance {Eq a} Eq [a]:-          --   eqCollection = \dict_Eq -> {| ("eq", eqCollectionEq dict_Eq), ... |}-          ---          -- Dictionary parameters will be automatically added by addDictionaryParametersT-          -- after type inference, so we don't add them here manually.-          -- We just create the hash with references to the methods.-          -          hashEntries = map (makeHashEntry clsNm typNm) meths-          hashExpr = IHashExpr hashEntries-      in (dictVar, hashExpr)+          methodEntries = map (makeHashEntry clsNm typNm) meths+      -- Add superclass dictionary references (Haskell-style nested dicts)+      superEntries <- makeSuperclassEntries clsNm typNm+      let hashExpr = IHashExpr (methodEntries ++ superEntries)+      return (dictVar, hashExpr)          makeHashEntry :: String -> String -> InstanceMethod -> (IExpr, IExpr)     makeHashEntry clsNm typNm (InstanceMethod methName _ _) =       let keyExpr = IConstantExpr (StringExpr (pack (sanitizeMethodName methName)))-          -- Reference to the method function           funcName = lowerFirst clsNm ++ typNm ++ capitalizeFirst (sanitizeMethodName methName)           valueExpr = IVarExpr funcName       in (keyExpr, valueExpr)++    makeSuperclassEntries :: String -> String -> EvalM [(IExpr, IExpr)]+    makeSuperclassEntries clsNm typNm = do+      classEnv <- getClassEnv+      case lookupClass clsNm classEnv of+        Just info -> return $ map (makeSuperEntry typNm) (classSupers info)+        Nothing   -> return []++    makeSuperEntry :: String -> String -> (IExpr, IExpr)+    makeSuperEntry typNm superName =+      let keyExpr = IConstantExpr (StringExpr (pack ("__super_" ++ superName)))+          superDictName = lowerFirst superName ++ typNm+          valueExpr = IVarExpr superDictName+      in (keyExpr, valueExpr)       -- Inductive declarations don't produce runtime code -- Constructor registration is handled by the type system desugarTopExpr (InductiveDecl _ _ _) = return Nothing +-- cas-type aliases and cas-subtype edges are fully handled during+-- environment building (Phase alpha/beta of the extensible tower);+-- no runtime artifact.+desugarTopExpr (DeclareCasType _ _) = return Nothing+desugarTopExpr (DeclareCasSubtype _ _) = return Nothing+desugarTopExpr (DeclareCasQuotient {}) = return Nothing  -- expanded before EnvBuilder+ -- Infix declarations don't produce runtime code desugarTopExpr (InfixDecl _ _) = return Nothing desugarTopExpr (PatternInductiveDecl _ _ _) = return Nothing  -- Handled in environment building phase  -- Pattern function declarations need type checking, so convert to IPatternFunctionDecl desugarTopExpr (PatternFunctionDecl name typeParams params retType body) = do-  let paramTypes = map (\(pname, pty) -> (pname, typeExprToType pty)) params-      retType' = typeExprToType retType+  aliasEnv <- getCasTypeAliasEnv+  let t2t = expandTypeAliases aliasEnv . typeExprToType+      paramTypes = map (\(pname, pty) -> (pname, t2t pty)) params+      retType' = t2t retType       tyVars = map TyVar typeParams   body' <- desugarPattern body   return . Just $ IPatternFunctionDecl name tyVars paramTypes retType' body'@@ -211,11 +240,591 @@ -- Symbol declarations desugarTopExpr (DeclareSymbol names mTypeExpr) = do   -- Convert type expression to type (defaults to Integer if not specified)+  aliasEnv <- getCasTypeAliasEnv   let ty = case mTypeExpr of-             Just texpr -> typeExprToType texpr+             Just texpr -> expandTypeAliases aliasEnv (typeExprToType texpr)              Nothing    -> typeExprToType TEInt+  -- Record the declaration order of CAS symbols for `declare ideal`+  -- (DG1: declared earlier = ranks lower = survives in normal forms).+  case ty of+    TInt       -> appendDeclaredSymbols names+    TMathValue -> appendDeclaredSymbols names+    _          -> return ()   return . Just $ IDeclareSymbol names (Just ty)+desugarTopExpr (DeclareRule mname level lhsPat rhs) = do+  -- Phase 7.5 (literal LHS) + Phase A (pattern variables `$x`, `#x`).+  --+  --   declare rule auto term i^2 = -1+  --   ⇒  def autoRule.<fresh> := \v -> applyTermRule i^2 (-1) v+  --+  -- With pattern variables (Phase A):+  --   declare rule trigPyth poly (sin $x)^2 + (cos #x)^2 = 1+  --   ⇒  def rule.trigPyth := \v -> match v as mathExpr with+  --                                  | (apply1 #sin $x)^2 + (apply1 #cos #x)^2 -> 1+  --                                  | _ -> v+  --+  -- Strategy:+  --   - If the LHS pattern contains no PatVar, take the literal-LHS path:+  --     reconstruct an Expr from the pattern and use `applyTermRule` so+  --     monomial-containment matching keeps working for term-level rules.+  --   - Otherwise, emit a `match v as <matcher> with | <pat> -> <rhs> | _ -> v`+  --     lambda. The user's surface syntax `f $x` (PApplyPat) is translated+  --     to `apply1 #f $x` so it matches mathExpr's matcher constructors.+  fr <- fresh+  let paramName = "__rule_input." ++ filter (\c -> c /= '$' && c /= '_') fr+  rhsI <- unNormalizeOps <$> desugar rhs+  let ruleTriggers = extractTriggerSymbols lhsPat+  body <- if patternHasPatVar lhsPat+            then buildPatternRuleBody paramName level lhsPat rhsI ruleTriggers+            else case patternToLiteralExpr lhsPat of+                   Just lhsExpr -> do+                     lhsI <- unNormalizeOps <$> desugar lhsExpr+                     buildLiteralRuleBody paramName level lhsI rhsI+                   Nothing ->+                     throwError $ Default+                       "declare rule LHS must be either a literal expression \+                       \or a pattern containing pattern variables ($x)."+  case mname of+    Just n -> do+      -- Named rule: emit `def rule.<n> := <body>` only.+      let varName = "rule." ++ n+      return . Just $ IDefine (stringToVar varName) body+    Nothing -> do+      -- Auto rule: emit two definitions:+      --   1. `def autoRule.<idx> := <body>` (the unwrapped rule lambda)+      --   2. `def mathNormalize := \v -> iterateRulesCAS [autoRule.0, ...]+      --                                                  (mathNormalizeBuiltin v)`+      --+      -- Triggers are stored in EvalState (already converted to `Set String`)+      -- and read inside iterateRulesCAS, so they aren't passed as arguments.+      appendAutoRuleTriggers ruleTriggers+      prevAutoNames <- getAutoRuleVarNames+      let autoVar    = "autoRule." ++ show (length prevAutoNames)+          allAutoVars = prevAutoNames ++ [autoVar]+      appendAutoRuleVarName autoVar+      mathNormBody <- buildMathNormalizeRedef allAutoVars+      return . Just $ IDefineMany+        [ (stringToVar autoVar, body)+        , (stringToVar "mathNormalize", mathNormBody)+        ]+  where+    -- Literal LHS path: \v -> applyTermRule lhs rhs v  (term-level)+    --                or \v -> if v = lhs then rhs else v  (poly/frac)+    buildLiteralRuleBody :: String -> RuleLevel -> IExpr -> IExpr -> EvalM IExpr+    buildLiteralRuleBody paramName lvl lhsI rhsI = case lvl of+      TermRuleLevel ->+        return $ ILambdaExpr Nothing [stringToVar paramName]+                   (IApplyExpr (IVarExpr "applyTermRule")+                               [lhsI, rhsI, IVarExpr paramName])+      _ ->+        return $ ILambdaExpr Nothing [stringToVar paramName]+                   (IIfExpr+                      (IApplyExpr (IVarExpr "=")+                                 [IVarExpr paramName, lhsI])+                      rhsI+                      (IVarExpr paramName)) +    -- Pattern-variable LHS path: emit a sub-expression-aware rule.+    -- The rule's "one step" lambda matches the user's pattern at a single+    -- value node (returning RHS on match, input otherwise). This single-step+    -- rule is then wrapped with the structural traversal primitive+    -- corresponding to the rule level:+    --   TermRuleLevel → mapTerm  (apply to each term/monomial)+    --   PolyRuleLevel → mapPoly  (apply at each (sub-)polynomial)+    --   FracRuleLevel → mapFrac  (apply at each (sub-)fraction)+    -- These primitives recurse into Apply1-4 / Quote / Function arguments+    -- automatically, so the rule fires at any sub-expression and iterates to+    -- a fixpoint at each visited node.+    buildPatternRuleBody :: String -> RuleLevel -> Pattern -> IExpr -> [String] -> EvalM IExpr+    buildPatternRuleBody paramName lvl pat rhsI triggers = do+      -- Use a separate fresh inner-arg name so the inner match is independent+      -- from the outer lambda parameter.+      frInner <- fresh+      let innerArg = "__rule_step." ++ filter (\c -> c /= '$' && c /= '_') frInner+          translated = wrapLhsForTermLevel (translateToMatcherPattern pat)+          mapPrim = case lvl of+            TermRuleLevel -> "mapTermAll"+            PolyRuleLevel -> "mapPolyAll"+            FracRuleLevel -> "mapFracAll"+          -- Inner one-step lambda built as Egison surface for desugar to handle+          -- the match-clause shape; we patch the RHS afterwards with rhsI.+          matchExpr = MatchExpr BFSMode+                        (VarExpr innerArg)+                        (VarExpr "mathExpr")+                        [(translated, ConstantExpr UndefinedExpr),+                         (WildCard,   VarExpr innerArg)]+      matchI <- desugar matchExpr+      let patchedMatchI = patchFirstMatchRhs matchI rhsI+          -- Per-term trigger guard: skip the matcher entirely on+          -- sub-values that contain none of the rule's trigger symbols.+          -- Sound with ANY-of semantics -- a sub-value the LHS can match+          -- necessarily contains the pattern's head symbol -- and cheap+          -- (one short-circuit scan vs. matcher startup).  The+          -- value-level filter in iterateRulesCAS already skips whole+          -- values; this covers the mixed case where only a few terms+          -- of a large value carry the trigger.+          guardedMatchI = case triggers of+            [] -> patchedMatchI+            _  -> IIfExpr+                    (IApplyExpr (IVarExpr "casContainsAnySymbol")+                      [ ICollectionExpr (map (IConstantExpr . StringExpr . pack) triggers)+                      , IVarExpr innerArg ])+                    patchedMatchI+                    (IVarExpr innerArg)+          oneStepLambda = ILambdaExpr Nothing [stringToVar innerArg] guardedMatchI+          mapCall       = IApplyExpr (IVarExpr mapPrim)+                                     [oneStepLambda, IVarExpr paramName]+      return $ ILambdaExpr Nothing [stringToVar paramName] mapCall++    -- Replace the first match clause's body in an IMatchExpr with the given+    -- IExpr. (We placeholder-desugar the match with `undefined`, then patch.)+    patchFirstMatchRhs :: IExpr -> IExpr -> IExpr+    patchFirstMatchRhs (IMatchExpr m tgt mtcher ((p, _) : rest)) newBody =+      IMatchExpr m tgt mtcher ((p, newBody) : rest)+    patchFirstMatchRhs e _ = e+-- G3 (design/cas-simplification.md): `declare ideal [g1, ..., gk]`.+--+--   declare ideal [w^2 + w + 1]+--     =>  def idealRules.N := idealTermRules [<priority atoms>] [g1', ..., gk']+--         def autoRule.N   := \v -> applyIdealRules idealRules.N v+--         def mathNormalize := ...   (same redefinition as declare rule auto)+--+-- The generators receive the same rule-free treatment as declare-rule+-- right-hand sides (unNormalizeOps), so generators that the active auto+-- rules would collapse are safe to write plainly.  The priority list is+-- the declaration order of `declare symbol` (DG1: earlier = survives),+-- extended by the compound atoms (symbolic applications, quotes) in the+-- order they appear in the generators.  idealTermRules computes the+-- reduced Groebner basis once (lazily, in the rule-free engine of+-- lib/math/algebra/groebner.egi -- the free-theory arithmetic is what+-- makes it safe to force the list while autoRule.N is already active)+-- and turns each element into a term-level rewrite pair (LT, LT - g).+desugarTopExpr (DeclareIdeal gens) = do+  gensI <- map unNormalizeOps <$> mapM desugar gens+  symOrder <- getDeclaredSymbolOrder+  let compounds = collectCompoundAtomExprs gensI+      piExprs   = map IVarExpr symOrder ++ compounds+      triggers  = concatMap iexprVarNames gensI+  appendAutoRuleTriggers triggers+  prevAutoNames <- getAutoRuleVarNames+  let idx         = show (length prevAutoNames)+      rulesVar    = "idealRules." ++ idx+      autoVar     = "autoRule." ++ idx+      allAutoVars = prevAutoNames ++ [autoVar]+  appendAutoRuleVarName autoVar+  let rulesBody = IApplyExpr (IVarExpr "idealTermRules")+                    [ICollectionExpr piExprs, ICollectionExpr gensI]+      ruleBody  = ILambdaExpr Nothing [stringToVar "v"]+                    (IApplyExpr (IVarExpr "applyIdealRules")+                                [IVarExpr rulesVar, IVarExpr "v"])+  mathNormBody <- buildMathNormalizeRedef allAutoVars+  return . Just $ IDefineMany+    [ (stringToVar rulesVar, rulesBody)+    , (stringToVar autoVar, ruleBody)+    , (stringToVar "mathNormalize", mathNormBody)+    ]++desugarTopExpr (DeclareDerivative name rhs) = do+  -- Phase 6.3 part 4-6: emit+  --   def deriv.<name> := <rhs>+  --   def chainPartialDiff := \v dx ->+  --       match v as mathValue with+  --         | apply1 #<n_1> $a -> deriv.<n_1> a *' chainPartialDiff a dx+  --         ...+  --         | apply1 #<n_k> $a -> deriv.<n_k> a *' chainPartialDiff a dx+  --         | _ -> chainPartialDiffBuiltin v dx+  --   where n_1..n_k are *all* the derivative names seen so far (including+  --   <name>). Each declare derivative redefines `chainPartialDiff` with the+  --   broader pattern set; Egison's name shadowing lets the latest+  --   definition win. The fallback uses `chainPartialDiffBuiltin` (defined in+  --   lib/math/analysis/derivative.egi and never redefined) so the+  --   recursion through nested mathfuncs terminates.+  rhsI <- desugar rhs+  -- Use only derivatives desugared *up to and including* this one, so the+  -- emitted chainPartialDiff body doesn't forward-reference `deriv.<later>`+  -- bindings. EnvBuilder pre-populates `derivativeRuleNames` with all names,+  -- but for code generation we want each declaration to reference only the+  -- names that have already been emitted.+  prevDesugared <- getDerivativesDesugared+  let allNames = prevDesugared ++ [name | name `notElem` prevDesugared]+  appendDerivativeDesugared name+  -- Build the chainPartialDiff body: a lambda over (v, dx) with a match.+  let derivBinding = (stringToVar ("deriv." ++ name), rhsI)+  chainBindingI <- buildChainPartialDiff allNames+  let chainBinding = (stringToVar "chainPartialDiff", chainBindingI)+  return . Just $ IDefineMany [derivBinding, chainBinding]+  where+    -- Build:+    --   \v dx -> match v as mathValue with+    --              | apply1 #<n1> $a -> deriv.<n1> a *' chainPartialDiff a dx+    --              ...+    --              | _ -> chainPartialDiffBuiltin v dx+    --+    -- We desugar a synthetic Egison expression rather than hand-building+    -- the IExpr tree, since match patterns and `apply1 #` are easier at+    -- the surface level.+    buildChainPartialDiff :: [String] -> EvalM IExpr+    buildChainPartialDiff names = do+      -- Recursive arm: deriv.<n> a *' partialDiff a dx.+      -- The recursive sub-call uses `partialDiff` (the typeclass method)+      -- so that the argument's runtime CAS shape decides which Differentiable+      -- instance handles it: this lets `partialDiff (sin (x^2)) x` decompose+      -- into `cos (x^2) * partialDiff (x^2) x = cos (x^2) * 2 x` correctly,+      -- because `partialDiff (x^2) x` dispatches to the Term instance.+      -- Nested mathfunc applications still work because partialDiff for+      -- Factor (apply1 _ _) routes through chainPartialDiff again.+      let mkClause n =+            ( InductivePat "apply1"+                 [ ValuePat (VarExpr n)+                 , PatVar "a"+                 ]+            , InfixExpr (Op "*'" 7 InfixL False)+                 (ApplyExpr (VarExpr ("deriv." ++ n)) [VarExpr "a"])+                 (ApplyExpr (VarExpr "partialDiff")+                            [VarExpr "a", VarExpr "dx"])+            )+          fallbackClause =+            ( WildCard+            , ApplyExpr (VarExpr "chainPartialDiffBuiltin") [VarExpr "v", VarExpr "dx"]+            )+          matchExpr = MatchExpr BFSMode+                        (VarExpr "v")+                        (VarExpr "mathValue")+                        (map mkClause names ++ [fallbackClause])+          lambda = LambdaExpr+                     [ Arg (APPatVar (VarWithIndices "v" []))+                     , Arg (APPatVar (VarWithIndices "dx" []))+                     ]+                     matchExpr+      desugar lambda+desugarTopExpr (DeclareMathFunc name _mType) = do+  -- Phase 6.3 part 5: emit a wrapper function that quotes the symbol on+  -- application:  def <name> (x : MathValue) : MathValue := '<name> x+  -- The parser builds `'name x` as `ApplyExpr (QuoteSymbolExpr (VarExpr name)) [VarExpr x]`,+  -- so we mirror that structure here.+  let body = LambdaExpr [Arg (APPatVar (VarWithIndices "x" []))]+                        (ApplyExpr (QuoteSymbolExpr (VarExpr name))+                                   [VarExpr "x"])+  bodyI <- desugar body+  return . Just $ IDefine (stringToVar name) bodyI+desugarTopExpr (DeclareApply name args body) = do+  -- Phase A: emit `def <name> := \<args> -> <body>` which overrides the+  -- wrapper generated by `declare mathfunc <name>`. Within the body, the+  -- user uses `'<name> arg` (quote) for the symbolic Factor fallback so+  -- recursion terminates; calling `<name> arg` (unquoted) re-enters this+  -- definition for further reduction.+  let argPats = map (Arg . APPatVar . (\n -> VarWithIndices n [])) args+      lam = LambdaExpr argPats body+  bodyI <- desugar lam+  return . Just $ IDefine (stringToVar name) bodyI++-- | Extract the names of literal symbols and functions referenced by a+-- declare-rule LHS pattern. Used to build a fast trigger-symbol filter so+-- the rule's body is only invoked when the input value contains at least+-- one of these names.+--+-- Examples:+--   i^2                  → ["i"]+--   (sqrt $a)^2          → ["sqrt"]+--   log (exp $n)         → ["log", "exp"]+--   $x ^ 3               → []   (no literal symbols, rule must always run)+--+-- An empty result means the rule should NOT be guarded (it might match any+-- value), so the desugarer should skip the wrapper in that case.+extractTriggerSymbols :: Pattern -> [String]+extractTriggerSymbols = nub . go+ where+  go (ValuePat e)        = exprNames e+  -- Only the HEAD of an application pattern is a trigger: a term+  -- matching `log (exp $n)` necessarily contains a log-application+  -- factor, so "log" alone suffices, and a smaller trigger set lets+  -- the rule be skipped on more values (e.g. exp-heavy values never+  -- attempt the log rule).  Argument symbols are implied, not needed.+  go (PApplyPat f _)     = exprNames f+  go (DApplyPat p ps)    = go p ++ concatMap go ps+  go (InfixPat _ a b)    = go a ++ go b+  go (AndPat a b)        = go a ++ go b+  go (OrPat a b)         = go a ++ go b+  go (ForallPat a b)     = go a ++ go b+  go (NotPat p)          = go p+  go (TuplePat ps)       = concatMap go ps+  go (InductivePat _ ps) = concatMap go ps+  go (InductiveOrPApplyPat _ ps) = concatMap go ps+  go (IndexedPat p _)    = go p+  go (LetPat _ p)        = go p+  go (LoopPat _ _ a b)   = go a ++ go b+  go (SeqConsPat a b)    = go a ++ go b+  go _                   = []++  -- An expression appearing in a literal position contributes its symbol+  -- names. We only descend into shapes where a "trigger symbol" sense+  -- exists; opaque sub-expressions (lambdas, lets, etc.) contribute none.+  exprNames :: Expr -> [String]+  exprNames (VarExpr n)          = [n]+  exprNames (QuoteSymbolExpr e)  = exprNames e+  exprNames (InfixExpr _ a b)    = exprNames a ++ exprNames b+  -- Same head-only refinement as PApplyPat above.+  exprNames (ApplyExpr f _)      = exprNames f+  -- Operator section like `(^)` or `(+ 1)`: the operator name itself is+  -- the trigger (e.g. `apply2 #(^) ...` should trigger only on values+  -- containing the `^` function).+  exprNames (SectionExpr op ml mr) = [repr op] ++ maybe [] exprNames ml ++ maybe [] exprNames mr+  exprNames _                    = []++  nub = go' []+   where+    go' acc []     = reverse acc+    go' acc (x:xs) | x `elem` acc = go' acc xs+                   | otherwise    = go' (x:acc) xs++-- | Detect whether a Pattern has any PatVar at any depth.+patternHasPatVar :: Pattern -> Bool+patternHasPatVar (PatVar _)        = True+patternHasPatVar (ValuePat _)      = False+patternHasPatVar WildCard          = False+patternHasPatVar (PredPat _)       = False+patternHasPatVar ContPat           = False+patternHasPatVar LaterPatVar       = False+patternHasPatVar (NotPat p)        = patternHasPatVar p+patternHasPatVar (AndPat a b)      = patternHasPatVar a || patternHasPatVar b+patternHasPatVar (OrPat a b)       = patternHasPatVar a || patternHasPatVar b+patternHasPatVar (ForallPat a b)   = patternHasPatVar a || patternHasPatVar b+patternHasPatVar (TuplePat ps)     = any patternHasPatVar ps+patternHasPatVar (InductivePat _ ps)            = any patternHasPatVar ps+patternHasPatVar (InductiveOrPApplyPat _ ps)    = any patternHasPatVar ps+patternHasPatVar (InfixPat _ a b)  = patternHasPatVar a || patternHasPatVar b+patternHasPatVar (IndexedPat p _)  = patternHasPatVar p+patternHasPatVar (LetPat _ p)      = patternHasPatVar p+patternHasPatVar (LoopPat _ _ a b) = patternHasPatVar a || patternHasPatVar b+patternHasPatVar (PApplyPat _ ps)  = any patternHasPatVar ps+patternHasPatVar (DApplyPat p ps)  = patternHasPatVar p || any patternHasPatVar ps+patternHasPatVar (VarPat _)        = False+patternHasPatVar (SeqConsPat a b)  = patternHasPatVar a || patternHasPatVar b+patternHasPatVar SeqNilPat         = False++-- | Convert a literal pattern (no PatVar) back to an Expr so we can desugar+-- it via the existing applyTermRule path. Returns Nothing if the pattern+-- contains constructs that don't have an Expr equivalent.+patternToLiteralExpr :: Pattern -> Maybe Expr+patternToLiteralExpr (ValuePat e)         = Just e+patternToLiteralExpr (InfixPat op a b)    = do+  ae <- patternToLiteralExpr a+  be <- patternToLiteralExpr b+  return $ InfixExpr op ae be+patternToLiteralExpr (PApplyPat f args)   = do+  argExprs <- mapM patternToLiteralExpr args+  return $ ApplyExpr f argExprs+patternToLiteralExpr (TuplePat ps)        = do+  es <- mapM patternToLiteralExpr ps+  return $ TupleExpr es+patternToLiteralExpr (InductivePat _ _)   = Nothing+patternToLiteralExpr WildCard             = Nothing+patternToLiteralExpr (PatVar _)           = Nothing+patternToLiteralExpr _                    = Nothing++-- | Translate a user-written rule LHS pattern into a pattern that uses+-- mathExpr/multExpr matcher constructors. Specifically, surface syntax+-- `f $x` (PApplyPat with a VarExpr/QuoteSymbolExpr function) is rewritten+-- to `apply1 #f $x` (InductivePat using mathExpr's apply1 clause).+translateToMatcherPattern :: Pattern -> Pattern+translateToMatcherPattern p = case p of+  PApplyPat funcExpr args ->+    let funcName = case funcExpr of+                     VarExpr n                   -> Just n+                     QuoteSymbolExpr (VarExpr n) -> Just n+                     _                            -> Nothing+        translatedArgs = map translateToMatcherPattern args+    in case (funcName, length translatedArgs) of+         (Just _, 1) ->+           InductivePat "apply1" (ValuePat funcExpr : translatedArgs)+         (Just _, 2) ->+           InductivePat "apply2" (ValuePat funcExpr : translatedArgs)+         (Just _, 3) ->+           InductivePat "apply3" (ValuePat funcExpr : translatedArgs)+         (Just _, 4) ->+           InductivePat "apply4" (ValuePat funcExpr : translatedArgs)+         _ -> PApplyPat funcExpr translatedArgs+  InfixPat op a b ->+    InfixPat op (translateToMatcherPattern a) (translateToMatcherPattern b)+  InductivePat n args ->+    InductivePat n (map translateToMatcherPattern args)+  TuplePat ps -> TuplePat (map translateToMatcherPattern ps)+  AndPat a b  -> AndPat (translateToMatcherPattern a) (translateToMatcherPattern b)+  OrPat a b   -> OrPat (translateToMatcherPattern a) (translateToMatcherPattern b)+  NotPat q    -> NotPat (translateToMatcherPattern q)+  IndexedPat q es -> IndexedPat (translateToMatcherPattern q) es+  _ -> p++-- | Top-level wrap of a translated rule LHS to enable multi-factor+-- decomposition. When the outer pattern is `f $x * g $y * ...` (a chain of+-- factor-shaped operands), the mathValue matcher's `$ * $` decomposes into+-- (coeff, monomial-as-multExpr) — not (factor, rest). To access the+-- (factor, integer, multExpr) decomposition path that handles apply1-4 via+-- the `factor` matcher, we must enter the multExpr context. The wrap is:+--+--   f $x * g $y+--     becomes+--   mult _ (((f $x) ^ #1) * ((g $y) ^ #1))+--+-- This is applied only at the TOP LEVEL (not inside other patterns) so that+-- patterns like `exp ($n * i * π)` are unaffected (the inner `$n * i * π`+-- is matched as the apply1 argument's mathValue, where (coeff, monomial)+-- decomposition is the right semantics).+wrapLhsForTermLevel :: Pattern -> Pattern+wrapLhsForTermLevel p+  | isMultChainOfFactorShapes p =+      InductivePat "mult" [WildCard, wrapFactorsInChain p]+  | otherwise = p++-- | Recursively wrap factor-shaped patterns inside a `*` chain with `^ #1`.+-- Operates only on top-level `*` chains — sub-patterns inside an apply+-- argument keep their original shape.+wrapFactorsInChain :: Pattern -> Pattern+wrapFactorsInChain (InfixPat op a b) | repr op == "*" =+  InfixPat op (wrapFactorsInChain a) (wrapFactorsInChain b)+wrapFactorsInChain p+  | isFactorShaped p =+      InfixPat (Op "^" 9 InfixN False) p+               (ValuePat (ConstantExpr (IntegerExpr 1)))+  | otherwise = p++-- | True if a pattern is an `*`-chain whose leaves are all factor-shaped+-- (apply1-4 / symbol / quote / func / a literal symbol via ValuePat VarExpr).+isMultChainOfFactorShapes :: Pattern -> Bool+isMultChainOfFactorShapes (InfixPat op a b) | repr op == "*" =+  isMultChainOfFactorShapes a && isMultChainOfFactorShapes b+isMultChainOfFactorShapes p = isFactorShaped p++-- | True if a pattern names a single CAS factor (apply1-4, symbol, etc.).+isFactorShaped :: Pattern -> Bool+isFactorShaped (InductivePat name _) =+  name `elem` ["apply1", "apply2", "apply3", "apply4", "symbol", "quote", "func"]+isFactorShaped (ValuePat (VarExpr _)) = True+isFactorShaped _ = False++-- | Replace normalizing arithmetic operators (`+`, `-`, `*`, `/`, `^`) with+-- their **primitive** Haskell-level counterparts. Used by `declare rule auto`+-- to avoid infinite recursion:+--+-- The lib's un-normalized operators (`+'`, `-'`, etc.) are direct aliases of+-- `i.+`/`i.-`/etc. But the lib's `power'` (used by `^'`) iterates via+-- `take`/`foldl`, which use `-` (subtraction) on Integer. Subtraction at the+-- MathValue level dispatches to `minusForMathValue`, which calls+-- `mathNormalize`, creating a cycle:+--   `mathNormalize` → rule body → `power' p 2` → `take 2 ...` → `n - 1`+--   → `mathNormalize` → ...+--+-- Bypassing this requires using the primitives **directly** in the rule body.+-- For `^` (power), the primitive `i.power` only works on integer arguments,+-- so we instead expand `x ^ n` (where `n` is a positive integer literal) into+-- repeated `i.* x x ... x` calls. This works for symbolic CAS values.+unNormalizeOps :: IExpr -> IExpr+unNormalizeOps e = case e of+  -- Special case: `x ^ n` where n is a literal positive integer.+  -- Expand to nested i.* (works for symbolic CAS values).+  IApplyExpr (IVarExpr "^")+             [base, IConstantExpr (IntegerExpr n)]+    | n >= 1 ->+        let base' = unNormalizeOps base+            mulPrim = IVarExpr "i.*"+            go 1 = base'+            go k = IApplyExpr mulPrim [base', go (k - 1)]+        in go n+  -- General case: `x ^ n` with non-literal n. Dispatch to `^'`, the+  -- un-normalised power operator that uses `power'` (which now uses+  -- direct recursion + i.- instead of take/foldl). This avoids the+  -- mathNormalize cycle when ^ appears in a declare-rule RHS.+  IApplyExpr (IVarExpr "^") [base, expn] ->+    IApplyExpr (IVarExpr "^'") [unNormalizeOps base, unNormalizeOps expn]+  IApplyExpr (IVarExpr nm) args+    | Just nm' <- lookup nm opTable ->+        IApplyExpr (IVarExpr nm') (map unNormalizeOps args)+  IApplyExpr f args ->+    IApplyExpr (unNormalizeOps f) (map unNormalizeOps args)+  ILambdaExpr mn vs body ->+    ILambdaExpr mn vs (unNormalizeOps body)+  IIfExpr c t f ->+    IIfExpr (unNormalizeOps c) (unNormalizeOps t) (unNormalizeOps f)+  ILetExpr bindings body ->+    ILetExpr [(p, unNormalizeOps b) | (p, b) <- bindings] (unNormalizeOps body)+  ITupleExpr es ->+    ITupleExpr (map unNormalizeOps es)+  ICollectionExpr es ->+    ICollectionExpr (map unNormalizeOps es)+  IConsExpr a b ->+    IConsExpr (unNormalizeOps a) (unNormalizeOps b)+  IJoinExpr a b ->+    IJoinExpr (unNormalizeOps a) (unNormalizeOps b)+  IInductiveDataExpr nm es ->+    IInductiveDataExpr nm (map unNormalizeOps es)+  IQuoteSymbolExpr e' ->+    IQuoteSymbolExpr (unNormalizeOps e')+  -- Other constructors: leave as-is (including IVarExpr, IConstantExpr,+  -- patterns, matcher refs, etc.). They don't contain operators.+  _ -> e+  where+    opTable :: [(String, String)]+    opTable =+      [ ("+", "i.+")+      , ("-", "i.-")+      , ("*", "i.*")+      , ("/", "i./")+      ]++-- Build the body of the redefined `mathNormalize`:+--   \v -> iterateRulesCAS [autoRule.0, ..., autoRule.N]+--                         (mathNormalizeBuiltin v)+-- iterateRulesCAS reads trigger sets from EvalState (cached as+-- [Set String] at desugar time) and runs the rule-application ++-- fixpoint loop, scanning the value once per iteration to skip any+-- rule whose trigger set is disjoint from the value's symbols.+-- Shared by `declare rule auto` and `declare ideal`.+buildMathNormalizeRedef :: [String] -> EvalM IExpr+buildMathNormalizeRedef autoVars = do+  let rulesList = ICollectionExpr $ map IVarExpr autoVars+      mathBuiltinCall = IApplyExpr (IVarExpr "mathNormalizeBuiltin") [IVarExpr "v"]+      iterCall = IApplyExpr (IVarExpr "iterateRulesCAS") [rulesList, mathBuiltinCall]+  return $ ILambdaExpr Nothing [stringToVar "v"] iterCall++-- Candidate compound atoms (symbolic applications, quoted expressions)+-- of desugared ideal generators, in appearance order (deduplicated).+-- They extend the declaration-order priority list: compound atoms are+-- not declared with `declare symbol`, so their rank comes from where+-- they first appear in the generators (DG1, cas-simplification 3.5).+collectCompoundAtomExprs :: [IExpr] -> [IExpr]+collectCompoundAtomExprs es = nubBy (\a b -> show a == show b) (concatMap go es)+  where+    structuralOps =+      ["i.+", "i.-", "i.*", "i./", "+'", "-'", "*'", "/'", "^'", "power", "power'"]+    go e = case e of+      IApplyExpr (IVarExpr nm) args+        | nm `elem` structuralOps -> concatMap go args+        | otherwise               -> e : concatMap go args+      IApplyExpr f args  -> go f ++ concatMap go args+      IQuoteExpr _       -> [e]+      ITupleExpr xs      -> concatMap go xs+      ICollectionExpr xs -> concatMap go xs+      IConsExpr a b      -> go a ++ go b+      IJoinExpr a b      -> go a ++ go b+      _                  -> []++-- All variable names occurring in an IExpr.  Conservative superset used+-- for the trigger-symbol set of `declare ideal` (extra names only make+-- the rule fire more often, never less).+iexprVarNames :: IExpr -> [String]+iexprVarNames e = case e of+  IVarExpr nm         -> [nm]+  IApplyExpr f args   -> iexprVarNames f ++ concatMap iexprVarNames args+  IQuoteExpr a        -> iexprVarNames a+  IQuoteSymbolExpr a  -> iexprVarNames a+  ITupleExpr xs       -> concatMap iexprVarNames xs+  ICollectionExpr xs  -> concatMap iexprVarNames xs+  IConsExpr a b       -> iexprVarNames a ++ iexprVarNames b+  IJoinExpr a b       -> iexprVarNames a ++ iexprVarNames b+  ILambdaExpr _ _ b   -> iexprVarNames b+  IIfExpr a b c       -> iexprVarNames a ++ iexprVarNames b ++ iexprVarNames c+  _                   -> []+ -- | Convert TypedParam to Arg ArgPattern for lambda expressions typedParamToArgPattern :: TypedParam -> Arg ArgPattern typedParamToArgPattern (TPVar pname _) =@@ -604,17 +1213,43 @@ desugar (QuoteExpr expr) =   IQuoteExpr <$> desugar expr -desugar (QuoteSymbolExpr expr) =-  IQuoteSymbolExpr <$> desugar expr+-- `'e` has two meanings, discriminated by the desugared inner form:+--   * `'f` (a variable, including operator sections like `'(^)`):+--     quote the function/symbol itself (QuoteSymbolExpr semantics).+--   * `'(expr)` (anything else): the rule-suppression quote -- build+--     expr with the rule-free structural arithmetic (i.+, i.*, ...),+--     the same treatment declare-rule right-hand sides receive.+--     `declare rule` rewriting does not fire inside, so ideal+--     generators such as '((sin θ)^2 + (cos θ)^2 - 1) survive+--     construction instead of collapsing under their own auto rules.+desugar (QuoteSymbolExpr expr) = do+  e <- desugar expr+  case e of+    IVarExpr _ -> return $ IQuoteSymbolExpr e+    _          -> return $ unNormalizeOps e  desugar (WedgeApplyExpr expr args) =   IWedgeApplyExpr <$> desugar expr <*> mapM desugar args  desugar (FunctionExpr args) = return $ IFunctionExpr args --- Type annotation is erased at runtime-desugar (TypeAnnotation expr _typeExpr) = desugar expr+-- Type annotation `(e : T)` desugars to `IReshape T (desugar e)` so that+-- the type checker validates `e`'s inferred type against `T` and the+-- evaluator structurally rewrites the runtime CAS value to fit `T`. For+-- non-CAS types `T`, the eval handler is a no-op (passes the value through).+desugar (TypeAnnotation expr typeExpr) = do+  inner <- desugar expr+  aliasEnv <- getCasTypeAliasEnv+  return $ IReshape (expandTypeAliases aliasEnv (typeExprToType typeExpr)) inner +-- `simplify <expr> using <ruleName>` (Phase 7.6).+-- Desugars to a direct call of the registered rule lambda:+--   simplify e using r  ⇒  rule.r e+-- The rule lambda was emitted by `desugarTopExpr (DeclareRule (Just r) ...)`.+desugar (SimplifyUsingExpr body ruleName) = do+  bodyI <- desugar body+  return $ IApplyExpr (IVarExpr ("rule." ++ ruleName)) [bodyI]+ -- Typed lambda is desugared to regular lambda desugar (TypedLambdaExpr params _retType body) = do   let args = map (\(name, _) -> Arg (APPatVar (VarWithIndices name []))) params@@ -836,7 +1471,8 @@ extractIndexExpr _                = error "extractIndexExpr: Not supported"  isExtendedIndice :: VarIndex -> Bool-isExtendedIndice VSubscript{}       = False-isExtendedIndice VSuperscript{}     = False-isExtendedIndice (VGroupScripts xs) = isExtendedIndice (head xs)-isExtendedIndice _                  = True+isExtendedIndice VSubscript{}            = False+isExtendedIndice VSuperscript{}          = False+isExtendedIndice (VGroupScripts (x:_))   = isExtendedIndice x+isExtendedIndice (VGroupScripts [])      = True+isExtendedIndice _                       = True

@@ -20,23 +20,27 @@   , EnvBuildResult(..)   ) where -import           Control.Monad              (foldM)+import           Control.Monad              (foldM, when) import           Control.Monad.Except       (throwError)-import           Control.Monad.State-import           Data.Char                  (toUpper, toLower)+import           Control.Monad.IO.Class     (liftIO)+import           Data.Char                  (isUpper) import qualified Data.HashMap.Strict        as HashMap+import           System.IO                  (hPutStrLn, stderr)  import           Language.Egison.AST-import           Language.Egison.Data       (EvalM)-import           Language.Egison.EvalState  (ConstructorInfo(..), ConstructorEnv, PatternConstructorEnv)-import           Language.Egison.IExpr      (Var(..), Index(..), stringToVar)+import           Language.Egison.Data       (EvalM, EgisonError(..))+import           Language.Egison.EvalState  (MonadEval(getConstructorEnv, getCasTypeAliasEnv, getCasSubtypeEdges), ConstructorInfo(..), ConstructorEnv, PatternConstructorEnv)+import           Language.Egison.Type.Pretty (prettyType)+import qualified Language.Egison.Type.Subtype as Subtype+import           Language.Egison.IExpr      (Var(..), stringToVar) import           Language.Egison.Desugar    (transVarIndex) import           Language.Egison.Type.Env   (TypeEnv, ClassEnv, PatternTypeEnv, emptyEnv, emptyClassEnv, emptyPatternEnv,                                              extendEnv, extendPatternEnv, addClass, addInstance, lookupClass) import qualified Language.Egison.Type.Types as Types-import           Language.Egison.Type.Types (Type(..), TyVar(..), Constraint(..), TypeScheme(..), TensorShape(..),-                                             ClassInfo, InstanceInfo, freeTyVars, typeToName, sanitizeMethodName, typeExprToType,+import           Language.Egison.Type.Types (Type(..), TyVar(..), Constraint(..), TypeScheme(..),+                                             freeTyVars, sanitizeMethodName, typeExprToType,                                              capitalizeFirst, lowerFirst)+import           Language.Egison.Type.Subst (emptySubst, singletonSubst, composeSubst, applySubst) import qualified Data.Set as Set  -- | Result of environment building phase@@ -46,6 +50,27 @@   , ebrConstructorEnv :: ConstructorEnv  -- ^ Data constructor information   , ebrPatternConstructorEnv :: PatternConstructorEnv  -- ^ Pattern constructor information   , ebrPatternTypeEnv :: PatternTypeEnv  -- ^ Pattern function information+  -- Phase 7.4/7.5: collected `declare rule` declarations. Stored as the raw+  -- (name, level, lhs, rhs) tuple. Rule application is not yet wired into+  -- normalization; this field exists so the data round-trips through env+  -- building and is available for inspection / future Phase 7.5 code.+  , ebrReductionRules :: [(Maybe String, RuleLevel, Pattern, Expr)]+  -- Phase 6.3: collected `declare derivative` declarations. Maps function+  -- name -> derivative expression. Wiring into `Differentiable Factor` is+  -- still pending; for now, just the registration list.+  , ebrDerivativeRules :: [(String, Expr)]+  -- Names of functions declared via `declare mathfunc`. Used by the+  -- DeclareApply handler to enforce that `declare apply foo ...` only+  -- appears after a corresponding `declare mathfunc foo`.+  , ebrMathFuncNames :: Set.Set String+  -- Phase alpha (extensible CAS tower): `declare cas-type` aliases declared+  -- in THIS batch, name -> fully expanded Type. Merged into the persistent+  -- EvalState alias env by the caller (Eval.buildAndMergeEnvironments).+  , ebrCasTypeAliases :: HashMap.HashMap String Type+  -- Phase beta: `declare cas-subtype` edges declared in THIS batch+  -- (alias-expanded, D1-checked, redundant ones included). Appended to the+  -- persistent EvalState edge list by the caller.+  , ebrCasSubtypeEdges :: [(Type, Type)]   } deriving (Show)  --------------------------------------------------------------------------------@@ -57,6 +82,42 @@ -- It must be called AFTER expandLoads (Phase 1) and BEFORE type inference (Phase 5). buildEnvironments :: [TopExpr] -> EvalM EnvBuildResult buildEnvironments exprs = do+  -- Names of value-level inductive types: this batch's `inductive` declarations PLUS the+  -- types already registered by earlier load units (the accumulated constructor env).+  -- Cross-batch coverage matters because a matcher defined in file B over a type declared+  -- in file A must still keep that type concrete in its signature (see concretizeDeclaredTypes);+  -- B's TopExpr list alone would not mention `inductive A`.+  priorCtorEnv <- getConstructorEnv+  priorAliases <- getCasTypeAliasEnv+  let declaredTypes = Set.fromList ([ n | InductiveDecl n _ _ <- exprs ]+                                    ++ [ ctorTypeName ci | ci <- HashMap.elems priorCtorEnv ])++  -- Phase alpha (extensible CAS tower): collect `declare cas-type` aliases+  -- first (prepass, so declaration order does not matter for users of the+  -- alias), then resolve alias-in-alias references to a fixpoint. Bodies are+  -- stored fully expanded so a single substitution pass suffices at use sites.+  newAliasesRaw <- foldM (collectCasTypeAlias declaredTypes priorAliases)+                         HashMap.empty+                         [ (n, te) | DeclareCasType n te <- exprs ]+  newAliases <- resolveCasTypeAliases priorAliases newAliasesRaw+  -- Restriction on open atom sets, checked on the fully expanded alias+  -- bodies (alias-in-alias expansion can only be judged after resolution):+  -- a nested Poly tower may contain at most one [..]+  -- (Types.hasAmbiguousOpenTower; the runtime reshape's atom routing would+  -- otherwise be ambiguous).+  mapM_ (\(n, t) ->+          when (Types.hasAmbiguousOpenTower t) $ throwError $ Default $+            "declare cas-type " ++ n ++ ": at most one open atom set [..] " +++            "may appear in a nested Poly tower: " ++ prettyType t)+        (HashMap.toList newAliases)+  let aliasEnv = HashMap.union newAliases priorAliases++  -- Phase beta: collect `declare cas-subtype` edges (alias-expanded) and run+  -- the D1 join-semilattice check per edge, in declaration order.+  priorEdges <- getCasSubtypeEdges+  newEdges <- foldM (collectCasSubtypeEdge aliasEnv priorEdges) []+                    [ (l, r) | DeclareCasSubtype l r <- exprs ]+   -- Start with empty environments   let initialResult = EnvBuildResult         { ebrTypeEnv = emptyEnv@@ -64,76 +125,208 @@         , ebrConstructorEnv = HashMap.empty         , ebrPatternConstructorEnv = emptyPatternEnv         , ebrPatternTypeEnv = emptyPatternEnv+        , ebrReductionRules = []+        , ebrDerivativeRules = []+        , ebrMathFuncNames = Set.empty+        , ebrCasTypeAliases = newAliases+        , ebrCasSubtypeEdges = newEdges         }-  +   -- Process each top-level expression to collect declarations-  foldM processTopExpr initialResult exprs+  foldM (processTopExpr declaredTypes aliasEnv) initialResult exprs --- | Process a single top-level expression to collect environment information-processTopExpr :: EnvBuildResult -> TopExpr -> EvalM EnvBuildResult-processTopExpr result topExpr = case topExpr of-  +-- | Validate and register a single `declare cas-type` alias.+-- Rules (design/type-cas-tower-implementation.md section 2):+--   * the alias name must be capitalized+--   * it must not clash with builtin type names, declared inductive types,+--     or an existing alias (no redeclaration)+--   * the body may reference previously declared aliases only (a leftover+--     alias name after expansion means a self/forward reference)+collectCasTypeAlias :: Set.Set String -> HashMap.HashMap String Type+                    -> HashMap.HashMap String Type -> (String, TypeExpr)+                    -> EvalM (HashMap.HashMap String Type)+collectCasTypeAlias declaredTypes priorAliases acc (name, te) = do+  when (not (startsUpper name)) $ throwError $ Default $+    "declare cas-type: alias name must be capitalized: " ++ name+  when (Set.member name Types.reservedCasTypeNames) $ throwError $ Default $+    "declare cas-type: alias name clashes with a builtin type: " ++ name+  when (Set.member name declaredTypes) $ throwError $ Default $+    "declare cas-type: alias name clashes with an inductive type: " ++ name+  -- A nominal entry `name -> TInductive name []` in the alias env is a+  -- cas-quotient type (registered by Eval.expandCasQuotientDecls).+  case HashMap.lookup name priorAliases of+    Just (TInductive n []) | n == name ->+      throwError $ Default $+        "declare cas-type: name is already a cas-quotient type: " ++ name+    _ -> return ()+  when (HashMap.member name priorAliases || HashMap.member name acc) $+    throwError $ Default $+      "declare cas-type: alias is already declared: " ++ name+  return (HashMap.insert name (typeExprToType te) acc)+  where+    startsUpper (c:_) = isUpper c+    startsUpper _     = False++-- | Validate and register a `declare cas-subtype A ⊂ B` edge (Phase beta;+-- D1 declare-time semilattice check, design/type-cas-tower.md §8 D1).+-- Redundant edges are stored anyway — their endpoints then participate in+-- the node set of later checks — with a warning.+collectCasSubtypeEdge :: HashMap.HashMap String Type -> [(Type, Type)]+                      -> [(Type, Type)] -> (TypeExpr, TypeExpr)+                      -> EvalM [(Type, Type)]+collectCasSubtypeEdge aliasEnv priorEdges acc (lhsTE, rhsTE) = do+  let lhs = Types.expandTypeAliases aliasEnv (typeExprToType lhsTE)+      rhs = Types.expandTypeAliases aliasEnv (typeExprToType rhsTE)+      edges = priorEdges ++ acc+      pp = prettyType+  when (not (Subtype.isCasType lhs) || not (Subtype.isCasType rhs)) $+    throwError $ Default $+      "declare cas-subtype: both sides must be CAS types: " +++      pp lhs ++ " <: " ++ pp rhs+  mapM_ (\side ->+          when (Types.hasAmbiguousOpenTower side) $ throwError $ Default $+            "declare cas-subtype: at most one open atom set [..] may " +++            "appear in a nested Poly tower: " ++ pp side)+        [lhs, rhs]+  case Subtype.checkEdgeAddition edges (lhs, rhs) of+    Subtype.EdgeCycle -> throwError $ Default $+      "declare cas-subtype " ++ pp lhs ++ " <: " ++ pp rhs +++      ": the reverse relation already holds; adding this edge would " +++      "collapse the two types into one order point (cycle)"+    Subtype.EdgeAmbiguous witnesses -> throwError $ Default $+      "declare cas-subtype " ++ pp lhs ++ " <: " ++ pp rhs +++      ": join would become ambiguous (D1 semilattice check).\n" +++      concatMap (\(x, y, j) ->+        "  pair (" ++ pp x ++ ", " ++ pp y ++ ") would get minimal upper bounds {" +++        pp j ++ ", " ++ pp rhs ++ "}\n" +++        "  hint: declare the completing edge first:\n" +++        "    declare cas-subtype " ++ pp j ++ " <: " ++ pp rhs ++ "\n")+        witnesses+    Subtype.EdgeRedundant -> do+      liftIO $ hPutStrLn stderr $+        "Warning: declare cas-subtype " ++ pp lhs ++ " <: " ++ pp rhs +++        " is already derivable (redundant edge)"+      return (acc ++ [(lhs, rhs)])+    Subtype.EdgeRefines witnesses -> do+      liftIO $ hPutStrLn stderr $+        "Warning: declare cas-subtype " ++ pp lhs ++ " <: " ++ pp rhs +++        " refines existing joins (values unchanged, static types get more precise):" +++        concatMap (\(x, y, j) ->+          "\n  join(" ++ pp x ++ ", " ++ pp y ++ "): " ++ pp j ++ " -> " ++ pp rhs)+          witnesses+      return (acc ++ [(lhs, rhs)])+    Subtype.EdgeOk -> return (acc ++ [(lhs, rhs)])++-- | Resolve alias-in-alias references to a fixpoint, so aliases may refer to+-- each other regardless of declaration order (prepass semantics, matching+-- the other `declare` families). Each round substitutes one nesting level;+-- a definition that keeps growing past |aliases| + 1 rounds is cyclic.+resolveCasTypeAliases :: HashMap.HashMap String Type -> HashMap.HashMap String Type+                      -> EvalM (HashMap.HashMap String Type)+resolveCasTypeAliases priorAliases = go (0 :: Int)+  where+    go rounds m+      | m' == m = return m+      | rounds > HashMap.size m + 1 =+          throwError $ Default $+            "declare cas-type: cyclic alias definition among: " +++            unwords (HashMap.keys m)+      | otherwise = go (rounds + 1) m'+      where+        full = HashMap.union m priorAliases+        m'   = HashMap.map (Types.expandTypeAliases full) m++-- | Rewrite bare declared-inductive-type names that 'typeExprToType' produced as+-- type variables (e.g. @Matcher Nat@ parses to @TMatcher (TVar "Nat")@) into the+-- concrete @TInductive@.  Without this, an explicit signature @nat : Matcher Nat@+-- is generalized to @forall a. Matcher a@, so a recursive matcher's self-reference+-- instantiates to a fresh inner type and fails the MatcherSlot structural check.+-- Only names declared via @inductive@ in this batch are rewritten; undeclared+-- capitalized names (e.g. a stale @MathExpr@) stay type variables.+concretizeDeclaredTypes :: Set.Set String -> Type -> Type+concretizeDeclaredTypes decls = applySubst subst+  where subst = foldr (\n s -> composeSubst (singletonSubst (TyVar n) (TInductive n [])) s)+                      emptySubst (Set.toList decls)++-- | Process a single top-level expression to collect environment information.+-- `aliasEnv` carries `declare cas-type` aliases (prior batches + this batch);+-- every TypeExpr conversion goes through `t2t` so alias names are expanded+-- before types are stored anywhere (Phase alpha of the extensible tower).+processTopExpr :: Set.Set String -> HashMap.HashMap String Type -> EnvBuildResult -> TopExpr -> EvalM EnvBuildResult+processTopExpr declaredTypes aliasEnv result topExpr = case topExpr of+   -- 1. Data Constructor Definitions (from InductiveDecl)   InductiveDecl typeName typeParams constructors -> do     let typeParamVars = map (TVar . TyVar) typeParams         adtType = TInductive typeName typeParamVars         typeEnv = ebrTypeEnv result         ctorEnv = ebrConstructorEnv result-    +     -- Register each constructor-    (typeEnv', ctorEnv') <- foldM (registerConstructor typeName typeParams adtType) -                                   (typeEnv, ctorEnv) +    (typeEnv', ctorEnv') <- foldM (registerConstructor aliasEnv typeName typeParams adtType)+                                   (typeEnv, ctorEnv)                                    constructors          return result { ebrTypeEnv = typeEnv', ebrConstructorEnv = ctorEnv' }   -  -- 2. Type Class Definitions (from ClassDeclExpr)-  ClassDeclExpr (ClassDecl className [typeParam] superClasses methods) -> do+  -- 2. Type Class Definitions (from ClassDeclExpr).+  -- Supports any number of type parameters (single-param `class Eq a` and+  -- multi-param `class Embed a b` go through the same path). Methods are still+  -- registered against the *first* parameter for backward compatibility with+  -- existing single-param infrastructure (Phase 5.5 multi-param-aware+  -- elaboration is a separate task).+  ClassDeclExpr (ClassDecl className typeParams superClasses methods) | not (null typeParams) -> do     let classEnv = ebrClassEnv result         typeEnv = ebrTypeEnv result-        tyVar = TyVar typeParam-        +        tyVars = map TyVar typeParams+         -- Extract superclass names from ConstraintExprs         superNames = map extractConstraintName superClasses-        +         -- Build method list with types-        methodsWithTypes = map extractMethodWithType methods-        +        methodsWithTypes = map (extractMethodWithType aliasEnv) methods+         -- Create ClassInfo         -- Note: Use qualified name to avoid ambiguity with ClassDecl.classMethods         classInfo = Types.ClassInfo           { Types.classSupers = superNames-          , Types.classParam = tyVar+          , Types.classParams = tyVars           , Types.classMethods = methodsWithTypes           }-        +         -- Register class         classEnv' = addClass className classInfo classEnv-        +         -- Register each class method to type environment-        typeEnv' = foldl (registerClassMethod tyVar className) typeEnv methods-    +        typeEnv' = foldl (registerClassMethod aliasEnv tyVars className) typeEnv methods+     return result { ebrClassEnv = classEnv', ebrTypeEnv = typeEnv' }-  -  ClassDeclExpr _ -> -    -- Unsupported class declaration format (multiple type parameters, etc.)++  ClassDeclExpr _ ->+    -- Class with no type parameters is rejected.     return result   -  -- 3. Instance Definitions (from InstanceDeclExpr)+  -- 3. Instance Definitions (from InstanceDeclExpr).+  -- Multi-param-friendly: instance declarations may carry one or more+  -- types (`instance Embed Integer (Frac Integer) where ...`). All of them+  -- are stored in `instTypes`; the legacy `instType` accessor reads the head.   InstanceDeclExpr (InstanceDecl context className instTypes methods) -> do     let classEnv = ebrClassEnv result         typeEnv = ebrTypeEnv result-        -        -- Get the main instance type-        mainInstType = case instTypes of++        -- Convert all instance types+        instanceTypeList = map t2t instTypes++        -- Get the primary instance type (head) for backward compatibility+        mainInstType = case instanceTypeList of           []    -> TAny-          (t:_) -> typeExprToType t-        +          (t:_) -> t+         -- Create InstanceInfo         instInfo = Types.InstanceInfo-          { Types.instContext = map constraintToInternal context+          { Types.instContext = map (constraintToInternal aliasEnv) context           , Types.instClass = className-          , Types.instType = mainInstType+          , Types.instTypes = instanceTypeList           , Types.instMethods = []  -- Methods are handled during desugaring/evaluation           }         @@ -141,10 +334,12 @@         classEnv' = addInstance className instInfo classEnv                  -- Register method type signatures for generated methods-        -- This prevents "Unbound variable" warnings during type inference-        -- Pass the instance context (constraints) to include in method types-        typeEnv' = registerInstanceMethods className mainInstType (map constraintToInternal context) methods classEnv' typeEnv-    +        -- This prevents "Unbound variable" warnings during type inference.+        -- Pass the full instance type list so the registered names match the+        -- ones Desugar emits (e.g. `embedMathValueMathValueEmbed`,+        -- `embedMathValueMathValue` for `instance Embed MathValue MathValue`).+        typeEnv' = registerInstanceMethods className mainInstType instanceTypeList (map (constraintToInternal aliasEnv) context) methods classEnv' typeEnv+     return result { ebrClassEnv = classEnv', ebrTypeEnv = typeEnv' }      -- 4. Type Signature Collection (from Define, DefineWithType)@@ -158,15 +353,16 @@         -- Create Var with index structure (content is Just Var, so map to Nothing)         var = Var name (map (fmap (const Nothing)) indexTypes)         params = typedVarParams typedVar-        retType = typeExprToType (typedVarRetType typedVar)-        paramTypes = map typedParamToType params-        -        -- Build function type-        funType = foldr TFun retType paramTypes+        retType = t2t (typedVarRetType typedVar)+        paramTypes = map (typedParamToType aliasEnv) params         +        -- Build function type, then keep declared inductive type names concrete+        -- (e.g. `nat : Matcher Nat` stays `Matcher Nat`, not `forall a. Matcher a`).+        funType = concretizeDeclaredTypes declaredTypes (foldr TFun retType paramTypes)+         -- Convert constraints from AST to internal representation-        constraints = map constraintToInternal (typedVarConstraints typedVar)-        +        constraints = map (constraintToInternal aliasEnv) (typedVarConstraints typedVar)+         -- Generalize free type variables in the type signature         -- This handles type parameters like {a, b, c} in def compose {a, b, c} ...         freeVars = Set.toList (freeTyVars funType)@@ -174,9 +370,19 @@                  typeEnv = ebrTypeEnv result         typeEnv' = extendEnv var typeScheme typeEnv-    ++    -- Restriction on open atom sets in the declared signature: a nested+    -- Poly tower may contain at most one [..] (the runtime reshape's atom+    -- routing would otherwise be ambiguous; Types.hasAmbiguousOpenTower).+    -- Definitions reach the reshape through TypedDesugar.maybeReshape, not+    -- the IReshape inference path, so the check lives at signature+    -- collection.+    when (Types.hasAmbiguousOpenTower funType) $ throwError $ Default $+      "def " ++ name ++ ": at most one open atom set [..] may appear " +++      "in a nested Poly tower: " ++ prettyType funType+     return result { ebrTypeEnv = typeEnv' }-  +   -- 5. Pattern Inductive Declarations (from PatternInductiveDecl)   PatternInductiveDecl typeName typeParams constructors -> do     let typeParamVars = map (TVar . TyVar) typeParams@@ -188,16 +394,16 @@         patternCtorEnv = ebrPatternConstructorEnv result          -- Register each pattern constructor to pattern constructor environment-    patternCtorEnv' <- foldM (registerPatternConstructor typeName typeParams patternType) -                              patternCtorEnv +    patternCtorEnv' <- foldM (registerPatternConstructor aliasEnv typeName typeParams patternType)+                              patternCtorEnv                               constructors          return result { ebrPatternConstructorEnv = patternCtorEnv' }      -- 6. Pattern Function Declarations (from PatternFunctionDecl)   PatternFunctionDecl name typeParams params retType _body -> do-    let paramTypes = map (typeExprToType . snd) params-        retType' = typeExprToType retType+    let paramTypes = map (t2t . snd) params+        retType' = t2t retType         -- Pattern function type: arg1 -> arg2 -> ... -> retType (without Pattern wrapper)         patternFuncType = foldr TFun retType' paramTypes         @@ -210,9 +416,16 @@          return result { ebrPatternTypeEnv = patternEnv' }   +  -- Phase alpha/beta: cas-type aliases and cas-subtype edges were collected+  -- in the prepass (buildEnvironments), so nothing to do per-declaration here.+  DeclareCasType _ _ -> return result+  DeclareCasSubtype _ _ -> return result+  -- M4: cas-quotient declarations are macro-expanded away before environment+  -- building (Eval.expandCasQuotientDecls); nothing should reach here.+  DeclareCasQuotient {} -> return result+   -- Other expressions don't contribute to environment building   Define {} -> return result-  DefineWithType {} -> return result   Test {} -> return result   Execute {} -> return result   LoadFile {} -> return result  -- Should not appear after expandLoads@@ -221,25 +434,90 @@   -- 7. Symbol Declarations (from DeclareSymbol)   DeclareSymbol names mTypeExpr -> do     let ty = case mTypeExpr of-               Just texpr -> typeExprToType texpr-               Nothing    -> TInt  -- Default to Integer (MathExpr)+               Just texpr -> t2t texpr+               Nothing    -> TInt  -- Default to Integer (MathValue)         scheme = Forall [] [] ty         typeEnv = ebrTypeEnv result         -- Add each symbol to the type environment         typeEnv' = foldr (\name env -> extendEnv (stringToVar name) scheme env) typeEnv names     return result { ebrTypeEnv = typeEnv' } +  -- 8. Reduction Rule Declarations (from DeclareRule, Phase 7.4)+  -- The parser accepts the rule and we now stash the (name, level, lhs, rhs)+  -- tuple in `ebrReductionRules` for later inspection / Phase 7.5 use.+  -- Application during `casNormalize` is still pending.+  DeclareRule mname level lhs rhs ->+    return result { ebrReductionRules = ebrReductionRules result +++                                          [(mname, level, lhs, rhs)] }++  -- 8b. Ideal declarations (G3 of cas-simplification).  They desugar to+  -- ordinary definitions (idealRules.N / autoRule.N / mathNormalize),+  -- which are typed like any other define; nothing to register here.+  DeclareIdeal _ -> return result++  -- 9. Derivative Declarations (from DeclareDerivative, Phase 6.3)+  -- Stash the (name, expr) pair in `ebrDerivativeRules`. Wiring into+  -- `Differentiable Factor`'s connection rule is still pending.+  DeclareDerivative name rhs ->+    return result { ebrDerivativeRules = ebrDerivativeRules result +++                                            [(name, rhs)] }++  -- 10. Math function declarations (Phase 6.3 part 5).+  -- Register the function's type signature so the inference engine knows+  -- `f : MathValue -> MathValue` (the wrapper body that quotes the symbol).+  -- Without this, binary operations like `f 3 + f 4` infer `Any + Any` and+  -- the type-class `+` dispatch fails (returning the method-name string+  -- "plus" where a CASData was expected).+  -- The default `MathValue -> MathValue` may be widened by a subsequent+  -- `declare apply` based on its argument count (see DeclareApply below).+  DeclareMathFunc name mTypeExpr -> do+    let ty = case mTypeExpr of+               Just texpr -> t2t texpr+               Nothing    -> TFun TMathValue TMathValue+        scheme = Forall [] [] ty+        typeEnv = ebrTypeEnv result+        typeEnv' = extendEnv (stringToVar name) scheme typeEnv+        names'   = Set.insert name (ebrMathFuncNames result)+    return result { ebrTypeEnv = typeEnv', ebrMathFuncNames = names' }++  -- 11. Math function application rules (Phase A of declare apply impl).+  -- Requires a prior `declare mathfunc <name>` so the function's type and+  -- intent are known. The actual implementation is emitted by Desugar as a+  -- plain `def` that overrides the mathfunc wrapper.+  -- Updates the registered type to `MathValue -> MathValue -> ... -> MathValue`+  -- (one MathValue per arg + result), unless `declare mathfunc` had an+  -- explicit type annotation that already matches arity.+  DeclareApply name args _body -> do+    if Set.member name (ebrMathFuncNames result)+      then do+        let arity = length args+            -- Build MathValue -> MathValue -> ... -> MathValue (n+1 MathValues)+            mathFunTy 0 = TMathValue+            mathFunTy n = TFun TMathValue (mathFunTy (n - 1))+            ty' = mathFunTy arity+            scheme' = Forall [] [] ty'+            typeEnv' = extendEnv (stringToVar name) scheme' (ebrTypeEnv result)+        return result { ebrTypeEnv = typeEnv' }+      else throwError $ Default $+        "declare apply " ++ name ++ ": no prior `declare mathfunc " ++ name ++ "`. " +++        "Add `declare mathfunc " ++ name ++ "` before this `declare apply` declaration."++  where+    -- typeExprToType + cas-type alias expansion (Phase alpha).+    t2t :: TypeExpr -> Type+    t2t = Types.expandTypeAliases aliasEnv . typeExprToType+ -------------------------------------------------------------------------------- -- Helper Functions --------------------------------------------------------------------------------  -- | Register a single data constructor-registerConstructor :: String -> [String] -> Type -                    -> (TypeEnv, ConstructorEnv) -> InductiveConstructor +registerConstructor :: HashMap.HashMap String Type -> String -> [String] -> Type+                    -> (TypeEnv, ConstructorEnv) -> InductiveConstructor                     -> EvalM (TypeEnv, ConstructorEnv)-registerConstructor typeName typeParams resultType (typeEnv, ctorEnv) +registerConstructor aliasEnv typeName typeParams resultType (typeEnv, ctorEnv)                     (InductiveConstructor ctorName argTypeExprs) = do-  let argTypes = map typeExprToType argTypeExprs+  let argTypes = map (Types.expandTypeAliases aliasEnv . typeExprToType) argTypeExprs              -- Constructor type: argTypes -> resultType       constructorType = foldr TFun resultType argTypes@@ -261,44 +539,53 @@      return (typeEnv', ctorEnv') --- | Register a class method to the type environment-registerClassMethod :: TyVar -> String -> TypeEnv -> ClassMethod -> TypeEnv-registerClassMethod tyVar className typeEnv (ClassMethod methName params retType _defaultImpl) =-  let paramTypes = map typedParamToType params-      methodType = foldr TFun (typeExprToType retType) paramTypes-      -      -- Method has constrained type: ClassName a => methodType-      constraint = Types.Constraint className (TVar tyVar)-      typeScheme = Types.Forall [tyVar] [constraint] methodType+-- | Register a class method to the type environment.+-- The constraint carries ALL class type parameters (multi-param-friendly).+-- For `class Coerce a b where coerce (x: a) : b`, the method is registered+-- with `forall a b. Coerce a b => a -> b`.+registerClassMethod :: HashMap.HashMap String Type -> [TyVar] -> String -> TypeEnv -> ClassMethod -> TypeEnv+registerClassMethod aliasEnv tyVars className typeEnv (ClassMethod methName params retType _defaultImpl) =+  let paramTypes = map (typedParamToType aliasEnv) params+      methodType = foldr TFun (Types.expandTypeAliases aliasEnv (typeExprToType retType)) paramTypes+      -- Constraint with all class type params (single-param classes still+      -- produce a singleton list).+      constraint = Types.Constraint className (map TVar tyVars)+      typeScheme = Types.Forall tyVars [constraint] methodType   in     extendEnv (stringToVar methName) typeScheme typeEnv  -- | Register type signatures for instance methods (generated during desugaring)--- This prevents "Unbound variable" warnings during type inference-registerInstanceMethods :: String -> Type -> [Constraint] -> [InstanceMethod] -> ClassEnv -> TypeEnv -> TypeEnv-registerInstanceMethods className instType instConstraints methods classEnv typeEnv =+-- This prevents "Unbound variable" warnings during type inference.+--+-- Names must match Desugar's `desugarInstanceMethod` / `makeDictDef`, which+-- concatenate the type-constructor name of EVERY instance type (multi-param+-- friendly): e.g. `instance Embed MathValue MathValue` →+-- `embedMathValueMathValueEmbed` (method) and `embedMathValueMathValue`+-- (dictionary).+registerInstanceMethods :: String -> Type -> [Type] -> [Constraint] -> [InstanceMethod] -> ClassEnv -> TypeEnv -> TypeEnv+registerInstanceMethods className instType instTypeList instConstraints methods classEnv typeEnv =   case lookupClass className classEnv of     Nothing -> typeEnv  -- Class not found, skip-    Just classInfo -> +    Just classInfo ->       -- Register each instance method-      let typeEnv' = foldr (registerInstanceMethod className instType instConstraints classInfo) typeEnv methods-      +      let typeEnv' = foldr (registerInstanceMethod className instType instTypeList instConstraints classInfo) typeEnv methods+           -- Also register the dictionary itself-          -- e.g., eqCollection : {Eq a} Hash String ([a] -> [a] -> Bool)-          typeName' = Types.typeConstructorName instType-          dictName = lowerFirst className ++ typeName'-          +          -- e.g., embedMathValueMathValue : Hash String (MathValue -> MathValue)+          instTypeName = concatMap Types.typeToName instTypeList+          dictName = lowerFirst className ++ instTypeName+           -- Build dictionary type: Hash String (method type)           -- All methods should have the same general shape, so we use the first one           dictValueType = case methods of             [] -> TAny-            _ -> case lookup (instanceMethodName (head methods)) (Types.classMethods classInfo) of+            (m:_) -> case lookup (instanceMethodName m) (Types.classMethods classInfo) of               Nothing -> TAny               Just methodType ->                 let tyVar = Types.classParam classInfo                     substitutedType = substituteTypeVar tyVar instType methodType                 in substitutedType-          +           dictType = THash TString dictValueType           freeVars = Set.toList (freeTyVars dictType)           dictScheme = Types.Forall freeVars instConstraints dictType@@ -307,26 +594,26 @@   where     instanceMethodName :: InstanceMethod -> String     instanceMethodName (InstanceMethod name _ _) = name-    -    registerInstanceMethod :: String -> Type -> [Constraint] -> Types.ClassInfo -> InstanceMethod -> TypeEnv -> TypeEnv-    registerInstanceMethod clsName instTy constraints classInfo (InstanceMethod methName _params _body) env =++    registerInstanceMethod :: String -> Type -> [Type] -> [Constraint] -> Types.ClassInfo -> InstanceMethod -> TypeEnv -> TypeEnv+    registerInstanceMethod clsName instTy instTyList constraints classInfo (InstanceMethod methName _params _body) env =       -- Find the method in the class definition       case lookup methName (Types.classMethods classInfo) of         Nothing -> env  -- Method not in class definition, skip-        Just methodType -> -          -- Substitute type variable with instance type+        Just methodType ->+          -- Substitute type variable with instance type (use first type for the method body type)           let tyVar = Types.classParam classInfo               substitutedType = substituteTypeVar tyVar instTy methodType-              -              -- Generate method name using type constructor name only (no type parameters)-              -- e.g., "eqCollectionEq" not "eqCollectionaEq"-              typeName' = Types.typeConstructorName instTy++              -- Generate method name from ALL instance types (matching Desugar)+              -- e.g., "embedMathValueMathValueEmbed" for instance Embed MathValue MathValue+              instTypeName = concatMap Types.typeToName instTyList               sanitizedName = sanitizeMethodName methName-              generatedMethodName = lowerFirst clsName ++ typeName' ++ capitalizeFirst sanitizedName-              +              generatedMethodName = lowerFirst clsName ++ instTypeName ++ capitalizeFirst sanitizedName+               -- Extract free type variables from the substituted type               freeVars = Set.toList (freeTyVars substitutedType)-              +               -- Create type scheme with constraints from the instance context               -- e.g., {Eq a} [a] -> [a] -> Bool for instance {Eq a} Eq [a]               typeScheme = Types.Forall freeVars constraints substitutedType@@ -335,55 +622,34 @@          -- Substitute type variable with concrete type in a type expression     substituteTypeVar :: TyVar -> Type -> Type -> Type-    substituteTypeVar oldVar newType = go-      where-        go TInt = TInt-        go TFloat = TFloat-        go TBool = TBool-        go TChar = TChar-        go TString = TString-        go (TVar v) | v == oldVar = newType-                    | otherwise = TVar v-        go (TTuple ts) = TTuple (map go ts)-        go (TCollection t) = TCollection (go t)-        go (TInductive name ts) = TInductive name (map go ts)-        go (TTensor t) = TTensor (go t)-        go (THash k v) = THash (go k) (go v)-        go (TMatcher t) = TMatcher (go t)-        go (TFun t1 t2) = TFun (go t1) (go t2)-        go (TIO t) = TIO (go t)-        go (TIORef t) = TIORef (go t)-        go TAny = TAny---- | Extract method name from ClassMethod-extractMethodName :: ClassMethod -> String-extractMethodName (ClassMethod name _ _ _) = name+    substituteTypeVar = Types.substTyVar  -- | Extract method name and type from ClassMethod-extractMethodWithType :: ClassMethod -> (String, Type)-extractMethodWithType (ClassMethod name params retType _) =-  let paramTypes = map typedParamToType params-      methodType = foldr TFun (typeExprToType retType) paramTypes+extractMethodWithType :: HashMap.HashMap String Type -> ClassMethod -> (String, Type)+extractMethodWithType aliasEnv (ClassMethod name params retType _) =+  let paramTypes = map (typedParamToType aliasEnv) params+      methodType = foldr TFun (Types.expandTypeAliases aliasEnv (typeExprToType retType)) paramTypes   in (name, methodType)  -- | Extract class name from ConstraintExpr extractConstraintName :: ConstraintExpr -> String extractConstraintName (ConstraintExpr clsName _) = clsName --- | Convert ConstraintExpr to internal Constraint-constraintToInternal :: ConstraintExpr -> Types.Constraint-constraintToInternal (ConstraintExpr clsName tyExprs) =-  Types.Constraint clsName (case tyExprs of -    [] -> TAny-    (t:_) -> typeExprToType t)+-- | Convert ConstraintExpr to internal Constraint.+-- Multi-param classes (e.g. `Coerce a b`) carry all class type parameters.+constraintToInternal :: HashMap.HashMap String Type -> ConstraintExpr -> Types.Constraint+constraintToInternal aliasEnv (ConstraintExpr clsName tyExprs) =+  Types.Constraint clsName (case tyExprs of+    [] -> [TAny]+    _  -> map (Types.expandTypeAliases aliasEnv . typeExprToType) tyExprs)  -- | Register a single pattern constructor-registerPatternConstructor :: String -> [String] -> Type -                           -> PatternConstructorEnv -> PatternConstructor +registerPatternConstructor :: HashMap.HashMap String Type -> String -> [String] -> Type+                           -> PatternConstructorEnv -> PatternConstructor                            -> EvalM PatternConstructorEnv-registerPatternConstructor _typeName typeParams resultType patternCtorEnv +registerPatternConstructor aliasEnv _typeName typeParams resultType patternCtorEnv                           (PatternConstructor ctorName argTypeExprs) = do-  let argTypes = map typeExprToType argTypeExprs+  let argTypes = map (Types.expandTypeAliases aliasEnv . typeExprToType) argTypeExprs              -- Pattern constructor type: arg1 -> arg2 -> ... -> resultType (without Pattern wrapper)       patternCtorType = foldr TFun resultType argTypes@@ -397,12 +663,15 @@      return patternCtorEnv' --- | Convert TypedParam to Type-typedParamToType :: TypedParam -> Type-typedParamToType (TPVar _ ty) = typeExprToType ty-typedParamToType (TPInvertedVar _ ty) = typeExprToType ty-typedParamToType (TPTuple elems) = TTuple (map typedParamToType elems)-typedParamToType (TPWildcard ty) = typeExprToType ty-typedParamToType (TPUntypedVar _) = TVar (TyVar "a")  -- Will be inferred-typedParamToType TPUntypedWildcard = TVar (TyVar "a")  -- Will be inferred+-- | Convert TypedParam to Type (cas-type aliases expanded)+typedParamToType :: HashMap.HashMap String Type -> TypedParam -> Type+typedParamToType aliasEnv = go+  where+    go (TPVar _ ty) = t2t ty+    go (TPInvertedVar _ ty) = t2t ty+    go (TPTuple elems) = TTuple (map go elems)+    go (TPWildcard ty) = t2t ty+    go (TPUntypedVar _) = TVar (TyVar "a")  -- Will be inferred+    go TPUntypedWildcard = TVar (TyVar "a")  -- Will be inferred+    t2t = Types.expandTypeAliases aliasEnv . typeExprToType 

@@ -9,12 +9,10 @@   2. expandLoads (File loading with caching)   3. Environment Building Phase (Collect data constructors, type classes, instances, type signatures)   4. Desugar (Syntactic desugaring)-  5. Type Inference Phase (Constraint generation, unification, type class constraint processing)-  6. Type Check Phase (Verify type annotations, check type class constraints)-  7. TypedTopExpr (Typed AST)-  8. TypedDesugar (Type-driven transformations: type class expansion, tensorMap insertion)-  9. TITopExpr (Evaluatable typed IR with type info preserved)- 10. Evaluation (Pattern matching execution, expression evaluation, IO actions)+  5-6. Type Inference Phase (Constraint generation, unification, TIExpr generation)+  7. TypedDesugar (Type-driven transformations: tensorMap insertion, type class expansion)+  8. Definition Binding (Recursive binding of all definitions)+  9. Evaluation (Pattern matching execution, expression evaluation, IO actions) -}  module Language.Egison.Eval@@ -38,7 +36,8 @@   ) where  import           Control.Monad              (foldM, forM_, when)-import           Data.List                  (intercalate, partition)+import           Data.IORef                 (newIORef)+import           Data.List                  (intercalate) import           Control.Monad.Except       (throwError, catchError) import           Control.Monad.Reader       (ask, asks) import           Control.Monad.State@@ -48,7 +47,6 @@ import           Language.Egison.CmdOptions import           Language.Egison.Core import           Language.Egison.Data-import           Language.Egison.Data.Utils     (newEvaluatedObjectRef) import           Language.Egison.Desugar (desugarExpr, desugarTopExpr, desugarTopExprs) import           Language.Egison.EnvBuilder (buildEnvironments, EnvBuildResult(..)) import           Language.Egison.EvalState  (MonadEval (..), ConstructorEnv, PatternConstructorEnv)@@ -56,16 +54,17 @@ import           Language.Egison.MathOutput (prettyMath) import           Language.Egison.Parser import qualified Language.Egison.Type.Types as Types-import           Language.Egison.Type.Infer (inferITopExpr, runInferWithWarningsAndState, InferState(..), initialInferStateWithConfig, permissiveInferConfig, defaultInferConfig)+import           Language.Egison.Type.Infer (inferITopExpr, runInferWithWarningsAndState, InferState(..), initialInferStateWithConfig, permissiveInferConfig, defaultInferConfig, cfgMatcherConsistencyWarnings) import           Language.Egison.Type.Env (TypeEnv, ClassEnv, PatternTypeEnv, extendEnvMany, envToList, classEnvToList, lookupInstances, patternEnvToList, mergeClassEnv, extendPatternEnv) import           Language.Egison.Type.TypeClassExpand () import           Language.Egison.Type.TypedDesugar (desugarTypedTopExprT_TensorMapOnly, desugarTypedTopExprT_TypeClassOnly)-import           Language.Egison.Type.Error (formatTypeError, formatTypeWarning)+import           Language.Egison.Type.Error (TypeError, formatTypeError, formatTypeWarning) import           Language.Egison.Type.Check (builtinEnv) import           Language.Egison.Type.Pretty (prettyTypeScheme, prettyType) import           Language.Egison.Pretty (prettyStr) import           Language.Egison.EvalState (ConstructorInfo(..)) import qualified Data.HashMap.Strict as HashMap+import qualified Data.Set as Set   -- | Evaluate an Egison expression.@@ -75,13 +74,8 @@ -------------------------------------------------------------------------------- -- Phase 1: expandLoads - File Loading with Caching ----------------------------------------------------------------------------------- Recursively expand all Load/LoadFile statements into a flat list of TopExprs.--- This phase handles file reading and prevents duplicate loading through caching.--- After this phase, all source code is loaded and ready for environment building.  -- | Expand all Load/LoadFile statements recursively into a flat list of TopExprs.--- Files are loaded recursively and deduplicated (same file loaded multiple times--- will only appear once in the final list). expandLoads :: [TopExpr] -> EvalM [TopExpr] expandLoads [] = return [] expandLoads (expr:rest) = case expr of@@ -104,279 +98,377 @@ --------------------------------------------------------------------------------  -- | Evaluate an Egison top expression.--- Implements the complete processing flow:---   expandLoads → Environment Building → Desugar → Type Inference/Check → ---   TypedDesugar → Evaluation evalTopExpr :: Env -> TopExpr -> EvalM (Maybe EgisonValue, Env) evalTopExpr env topExpr = do-  -- Phase 1: Expand all Load/LoadFile recursively   expanded <- expandLoads [topExpr]-  -- Phase 2-10: Process all expanded expressions through remaining pipeline   evalExpandedTopExprsTyped env expanded  -- | Evaluate expanded top expressions using typed pipeline--- TODO: Implement type environment accumulation for proper type checking evalExpandedTopExprsTyped :: Env -> [TopExpr] -> EvalM (Maybe EgisonValue, Env) evalExpandedTopExprsTyped env exprs = evalExpandedTopExprsTyped' env exprs False True  ----------------------------------------------------------------------------------- Phase 2-10: Environment Building → Desugar → Type Inference/Check → ---             TypedDesugar → Evaluation+-- Pipeline Accumulator -------------------------------------------------------------------------------- +-- | Accumulator used during per-expression fold in phases 3-8.+-- Separates value bindings, pattern function bindings, non-definition expressions,+-- and optional dump lists for --dump-typed / --dump-ti / --dump-tc flags.+data PipelineAccum = PipelineAccum+  { accumBindings       :: [(Var, IExpr)]+  , accumPatFuncBindings :: [(String, IExpr)]+  , accumNonDefExprs    :: [(ITopExpr, Bool)]+  , accumTypedExprs     :: [Maybe TITopExpr]+  , accumTiExprs        :: [Maybe TITopExpr]+  , accumTcExprs        :: [Maybe TITopExpr]+  }++emptyAccum :: PipelineAccum+emptyAccum = PipelineAccum [] [] [] [] [] []++-- | Classify an ITopExpr into one of the accumulator bins.+classifyITopExpr :: ITopExpr -> Bool -> PipelineAccum -> PipelineAccum+classifyITopExpr iExpr printValues acc = case iExpr of+  IDefine name expr ->+    acc { accumBindings = accumBindings acc ++ [(name, expr)] }+  IDefineMany defs ->+    acc { accumBindings = accumBindings acc ++ defs }+  IPatternFunctionDecl name _tyVars params _retType body ->+    let paramNames = map fst params+        patternFuncExpr = IPatternFuncExpr paramNames body+    in acc { accumPatFuncBindings = accumPatFuncBindings acc ++ [(name, patternFuncExpr)] }+  _ ->+    acc { accumNonDefExprs = accumNonDefExprs acc ++ [(iExpr, printValues)] }++--------------------------------------------------------------------------------+-- Phase 2-9: Environment Building → Desugar → Type Inference →+--            TypedDesugar → Binding → Evaluation+--------------------------------------------------------------------------------+ -- | Evaluate expanded top expressions using the typed pipeline with optional printing.--- This function implements phases 2-10 of the processing flow. evalExpandedTopExprsTyped' :: Env -> [TopExpr] -> Bool -> Bool -> EvalM (Maybe EgisonValue, Env) evalExpandedTopExprsTyped' env exprs printValues shouldDumpTyped = do   opts <- ask-  -  ---------------------------------------------------------------------------------  -- Phase 2: Environment Building Phase (完全に独立したフェーズ)-  ---------------------------------------------------------------------------------  -- Collect ALL environment information BEFORE type inference begins:-  --   1. Data constructor definitions (from InductiveDecl)-  --   2. Type class definitions (from ClassDeclExpr)-  --   3. Instance definitions (from InstanceDeclExpr)-  --   4. Type signatures (from DefineWithType)-  -  -- Get existing environments (may contain previously loaded libraries)++  -- M4 (quotient mechanism, design/type-cas-quotient.md): macro-expand+  -- `declare cas-quotient` into ordinary defs/instances/assertions BEFORE+  -- environment building, so the generated instances and signatures flow+  -- through the normal prepass.+  exprs' <- expandCasQuotientDecls exprs++  -- Phase 2: Environment Building+  buildAndMergeEnvironments exprs' opts++  -- Pre-bind declared symbols. `declare symbol K` (uppercase) would+  -- otherwise fall through to the InductiveData fallback in IVarExpr at+  -- runtime, so any def whose body mentions `K` (e.g. `def W := 1/(1-K*r^2)`)+  -- would have to *capture* an env with K bound — but the IDeclareSymbol+  -- top expr is processed in Phase 9 (after recursiveBindAll), so without+  -- this pre-binding the def closure captures an env where K is missing.+  -- Binding here makes the symbol visible to subsequent defs and to the+  -- IDeclareSymbol pass itself (which is then a no-op).+  envWithSymbols <- preBindDeclaredSymbols env exprs'++  let permissive = not (optTypeCheckStrict opts)++  -- Phases 3-8: Desugar, type-infer, typed-desugar each expression.+  -- The definition names of the whole batch let the inferencer tell a+  -- forward reference (defined later in this load unit) apart from a+  -- genuinely unknown name when a variable is unbound.+  let batchDefNames = Set.fromList+        [ n | e <- exprs'+            , Just n <- [case e of+                           Define (VarWithIndices n' _) _ -> Just n'+                           DefineWithType tv _            -> Just (typedVarName tv)+                           _                              -> Nothing] ]+  accum <- foldM (processOneExpr opts permissive printValues batchDefNames) emptyAccum exprs'++  -- Dump typed ASTs before evaluation+  when (optDumpTyped opts && shouldDumpTyped) $+    dumpPhaseExprs "Typed AST (Phase 5-6: Type Inference)" "End of Typed AST" (accumTypedExprs accum)+  when (optDumpTi opts && shouldDumpTyped) $+    dumpPhaseExprs "Typed AST after TensorMap Insertion (Phase 7a)" "End of TensorMap Insertion AST" (accumTiExprs accum)+  when (optDumpTc opts && shouldDumpTyped) $+    dumpPhaseExprs "Typed AST after Type Class Expansion (Phase 7b)" "End of Type Class Expansion AST" (accumTcExprs accum)++  -- Phase 8: Bind all definitions together (supports mutual recursion)+  envWithPatFuncs <- recursiveBindAll envWithSymbols (accumBindings accum) (accumPatFuncBindings accum)++  -- Phase 9: Evaluate non-definition expressions in order.+  -- We catch each expression's error so that subsequent expressions still+  -- run (so a single failed `assertEqual` doesn't hide errors in later+  -- assertions). But we COLLECT the errors and re-throw at the end so the+  -- outer EvalM resolves to `Left` — required for `cabal test`'s+  -- `assertEvalM` to report the test as failed.+  (lastVal, finalEnv, collectedErrs) <-+    foldM (\(lastVal, currentEnv, errsAcc) (iExpr, shouldPrint) -> do+      evalResult <- catchError+        (Right <$> evalTopExpr' currentEnv iExpr)+        (\err -> do+          liftIO $ hPutStrLn stderr $ "Evaluation error: " ++ show err+          return $ Left err)++      case evalResult of+        Left err -> return (lastVal, currentEnv, err : errsAcc)+        Right (mVal, env'') -> do+          when shouldPrint $ case mVal of+            Nothing -> return ()+            Just val -> valueToStr val >>= liftIO . putStrLn+          return (mVal, env'', errsAcc)+    ) (Nothing, envWithPatFuncs, []) (accumNonDefExprs accum)++  -- If any expression produced an error, surface the FIRST one so the+  -- outer EvalM is `Left`. The full set has already been streamed to+  -- stderr above. Re-throw only when we collected something to avoid+  -- spurious failures on success paths.+  case reverse collectedErrs of+    []      -> return ()+    (err:_) -> throwError err++  return (lastVal, finalEnv)++--------------------------------------------------------------------------------+-- M4: cas-quotient macro expansion (design/type-cas-quotient.md q1-q4)+--------------------------------------------------------------------------------++-- | Expand `declare cas-quotient Q := Base by reduce` into ordinary+-- definitions, instances, and congruence-law assertions:+--+--   def reduceQ := <reduce>                      (user AST, spliced directly)+--   def projQ (x : MathValue) : Q := casQuotientCast (reduceQ x)+--   def reprQ (v : Q) : MathValue := casQuotientCast v+--   instance Eq/AddSemigroup/../Ring Q           (homomorphic ops:+--                                                 projQ (reprQ a ∘' reprQ b))+--   assertEqual ... (q4: idempotence + congruence over a sample battery)+--+-- Nominal typing (q1) comes from registering Q in the cas-type alias+-- environment as Q -> TInductive Q [], so every annotation seam maps the+-- bare name to an opaque type that unifies only with itself and joins no+-- subtype order (D4: quotients live outside the tower; `declare+-- cas-subtype` rejects them as non-CAS types).+--+-- Notes: crossing is explicit (projQ / reprQ). The homomorphic delegation+-- is sound because reduce is a ring-homomorphism kernel projection (checked+-- by the generated congruence assertions); non-homomorphic operations+-- (inv, gcd, comparisons) must be defined on Q directly (pattern 2).+expandCasQuotientDecls :: [TopExpr] -> EvalM [TopExpr]+expandCasQuotientDecls exprs = concat <$> mapM expand exprs+  where+    expand (DeclareCasQuotient name _baseTE reduceExpr) = do+      aliases <- getCasTypeAliasEnv+      ctorEnv <- getConstructorEnv+      when (Set.member name Types.reservedCasTypeNames) $ throwError $ Default $+        "declare cas-quotient: name clashes with a builtin type: " ++ name+      when (HashMap.member name aliases) $ throwError $ Default $+        "declare cas-quotient: name is already declared (cas-type alias or quotient): " ++ name+      when (any ((== name) . ctorTypeName) (HashMap.elems ctorEnv)) $+        throwError $ Default $+          "declare cas-quotient: name clashes with an inductive type: " ++ name+      -- q1: nominal registration through the alias environment+      setCasTypeAliasEnv (HashMap.insert name (Types.TInductive name []) aliases)+      generated <- readTopExprs (casQuotientTemplate name)+      return (Define (VarWithIndices ("reduce" ++ name) []) reduceExpr : generated)+    expand e = return [e]++-- | The generated program for one quotient declaration (q2/q3/q4).+-- Kept as concrete source text and re-parsed: every piece is ordinary+-- Egison, which keeps the mechanism a plain macro.+casQuotientTemplate :: String -> String+casQuotientTemplate q = unlines+  [ "def proj" ++ q ++ " (x : MathValue) : " ++ q ++ " := casQuotientCast (" ++ red ++ " x)"+  , "def repr" ++ q ++ " (v : " ++ q ++ ") : MathValue := casQuotientCast v"+  , "instance Eq " ++ q ++ " where"+  , "  (==) a b := (" ++ red ++ " ((repr" ++ q ++ " a) -' (repr" ++ q ++ " b))) = 0"+  , "  (/=) a b := not ((" ++ red ++ " ((repr" ++ q ++ " a) -' (repr" ++ q ++ " b))) = 0)"+  , "instance AddSemigroup " ++ q ++ " where"+  , "  (+) a b := proj" ++ q ++ " ((repr" ++ q ++ " a) +' (repr" ++ q ++ " b))"+  , "instance AddMonoid " ++ q ++ " where"+  , "  zero := proj" ++ q ++ " 0"+  , "instance AddGroup " ++ q ++ " where"+  , "  neg a := proj" ++ q ++ " (0 -' (repr" ++ q ++ " a))"+  , "instance MulSemigroup " ++ q ++ " where"+  , "  (*) a b := proj" ++ q ++ " ((repr" ++ q ++ " a) *' (repr" ++ q ++ " b))"+  , "instance MulMonoid " ++ q ++ " where"+  , "  one := proj" ++ q ++ " 1"+  , "instance Ring " ++ q+  , "assertEqual \"cas-quotient " ++ q ++ ": reduce is idempotent (sample battery)\""+  , "  (map (\\s -> " ++ red ++ " (" ++ red ++ " s)) " ++ battery ++ ")"+  , "  (map (\\s -> " ++ red ++ " s) " ++ battery ++ ")"+  , "assertEqual \"cas-quotient " ++ q ++ ": reduce is a congruence for +' (sample battery)\""+  , "  (map (\\p -> " ++ red ++ " ((fst p) +' (snd p))) " ++ pairs ++ ")"+  , "  (map (\\p -> " ++ red ++ " ((" ++ red ++ " (fst p)) +' (" ++ red ++ " (snd p)))) " ++ pairs ++ ")"+  , "assertEqual \"cas-quotient " ++ q ++ ": reduce is a congruence for *' (sample battery)\""+  , "  (map (\\p -> " ++ red ++ " ((fst p) *' (snd p))) " ++ pairs ++ ")"+  , "  (map (\\p -> " ++ red ++ " ((" ++ red ++ " (fst p)) *' (" ++ red ++ " (snd p)))) " ++ pairs ++ ")"+  ]+  where+    red = "reduce" ++ q+    battery = "[0, 1, -1, 2, 5, 12]"+    pairs = "[(0, 1), (1, 2), (-1, 5), (2, 12), (5, -1), (12, 7)]"++--------------------------------------------------------------------------------+-- Phase 2: Environment Building & Merging+--------------------------------------------------------------------------------++buildAndMergeEnvironments :: [TopExpr] -> EgisonOpts -> EvalM ()+buildAndMergeEnvironments exprs opts = do   currentTypeEnv <- getTypeEnv   currentClassEnv <- getClassEnv   currentPatternEnv <- getPatternEnv+  currentPatternFuncEnv <- getPatternFuncEnv -  -- Build environments from current expressions   envResult <- buildEnvironments exprs -  -- Merge existing environments with newly built environments-  -- New definitions extend existing ones (can override)   let newTypeEnv = ebrTypeEnv envResult-      -- If currentTypeEnv is empty, use builtinEnv as base       baseTypeEnv = if null (envToList currentTypeEnv) then builtinEnv else currentTypeEnv       mergedTypeEnv = extendEnvMany (envToList newTypeEnv) baseTypeEnv       mergedClassEnv = mergeClassEnv currentClassEnv (ebrClassEnv envResult)-      -- Merge pattern environments (new definitions can override)-      -- Pattern constructors from ebrPatternConstructorEnv and pattern functions from ebrPatternTypeEnv       patternConstructorEnv = ebrPatternConstructorEnv envResult       newPatternFuncEnv = ebrPatternTypeEnv envResult-  -  -- Get current pattern function environment-  currentPatternFuncEnv <- getPatternFuncEnv-  -  let -- Merge both into a single pattern environment-      mergedPatternEnv = foldr (\(name, scheme) env -> extendPatternEnv name scheme env) -                               (foldr (\(name, scheme) env -> extendPatternEnv name scheme env)+      mergedPatternEnv = foldr (\(name, scheme) e -> extendPatternEnv name scheme e)+                               (foldr (\(name, scheme) e -> extendPatternEnv name scheme e)                                       currentPatternEnv                                       (patternEnvToList patternConstructorEnv))                                (patternEnvToList newPatternFuncEnv)-      -- Also update pattern function environment separately-      mergedPatternFuncEnv = foldr (\(name, scheme) env -> extendPatternEnv name scheme env)+      mergedPatternFuncEnv = foldr (\(name, scheme) e -> extendPatternEnv name scheme e)                                    currentPatternFuncEnv                                    (patternEnvToList newPatternFuncEnv) -  -- Update EvalState with merged environments   setTypeEnv mergedTypeEnv   setClassEnv mergedClassEnv   setPatternEnv mergedPatternEnv   setPatternFuncEnv mergedPatternFuncEnv-  -  -- Register constructors to EvalState++  -- Phase alpha (extensible CAS tower): persist `declare cas-type` aliases so+  -- Desugar (this batch) and later load batches can expand annotation types.+  prevAliases <- getCasTypeAliasEnv+  setCasTypeAliasEnv (HashMap.union (ebrCasTypeAliases envResult) prevAliases)++  -- Phase beta: persist `declare cas-subtype` edges (D1-checked in EnvBuilder).+  prevEdges <- getCasSubtypeEdges+  setCasSubtypeEdges (prevEdges ++ ebrCasSubtypeEdges envResult)++  -- Phase 7.4/7.5/6.3: surface declaration counts and names to the runtime+  -- so that inspection primitives (`numReductionRules`, `ruleNames`,+  -- `numDerivativeRules`, `derivativeNames`) can read them. The full data+  -- (LHS/RHS Exprs) is in EnvBuildResult and not yet plumbed; only counts+  -- and names propagate.+  prevR <- getReductionRulesCount+  setReductionRulesCount (prevR + length (ebrReductionRules envResult))+  prevD <- getDerivativeRulesCount+  setDerivativeRulesCount (prevD + length (ebrDerivativeRules envResult))+  prevRNames <- getReductionRuleNames+  setReductionRuleNames (prevRNames +++    [ n | (Just n, _, _, _) <- ebrReductionRules envResult ])+  prevDNames <- getDerivativeRuleNames+  setDerivativeRuleNames (prevDNames +++    [ n | (n, _) <- ebrDerivativeRules envResult ])+   forM_ (HashMap.toList (ebrConstructorEnv envResult)) $ \(ctorName, ctorInfo) ->     registerConstructor ctorName ctorInfo-  -  -- Dump environment if requested-  when (optDumpEnv opts) $ do-    dumpEnvironment mergedTypeEnv mergedClassEnv (ebrConstructorEnv envResult) ++  when (optDumpEnv opts) $+    dumpEnvironment mergedTypeEnv mergedClassEnv (ebrConstructorEnv envResult)                     (ebrPatternConstructorEnv envResult) (ebrPatternTypeEnv envResult)-  -  -- Dump desugared AST if requested+   when (optDumpDesugared opts) $ do     desugaredExprs <- desugarTopExprs exprs     dumpDesugared (map Just desugaredExprs)-  -  -- Get the environments for type inference-  -- Permissive mode allows falling back to untyped evaluation on type errors-  let permissive = not (optTypeCheckStrict opts)-  -  -- Process each expression sequentially through phases 3-8 (type inference and desugaring)-  -- Collect all definitions to bind them together later (Phase 9)-  -- Non-definition expressions (ITest, IExecute) will be evaluated in Phase 10-  -- Also collect typed ASTs if dump-typed, dump-ti, or dump-tc is enabled-  -- The accumulator separates regular value bindings from pattern function bindings so-  -- they can be placed in different environments after collection.-  ((allBindings, allPatFuncBindings, nonDefExprs), typedExprs, tiExprs, tcExprs) <- foldM (\((bindings, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs) expr -> do-    -- Get current type and class environments from EvalState-    currentTypeEnv <- getTypeEnv-    currentClassEnv <- getClassEnv-    -    -- Phase 3-4: Desugar (TopExpr → ITopExpr)-    mITopExpr <- desugarTopExpr expr-    -    case mITopExpr of-      Nothing -> return ((bindings, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)  -- No desugared output-      Just iTopExpr -> do-        -- Phase 5-6: Type Inference (ITopExpr → TypedITopExpr)-        let inferConfig = if permissive then permissiveInferConfig else defaultInferConfig-        -- Get the current pattern environment from EvalState-        currentPatternEnv' <- getPatternEnv-        currentPatternFuncEnv' <- getPatternFuncEnv-        -- Add pattern function types to inferEnv so they can be referenced as variables-        let patternFuncBindings = [(stringToVar name, scheme) | (name, scheme) <- patternEnvToList currentPatternFuncEnv']-            enrichedTypeEnv = extendEnvMany patternFuncBindings currentTypeEnv-            initState = (initialInferStateWithConfig inferConfig) {-              inferEnv = enrichedTypeEnv,-              inferClassEnv = currentClassEnv,-              inferPatternEnv = currentPatternEnv',-              inferPatternFuncEnv = currentPatternFuncEnv'-            }-        (result, warnings, finalState) <- liftIO $ -          runInferWithWarningsAndState (inferITopExpr iTopExpr) initState-        -        let updatedTypeEnv = inferEnv finalState-        let updatedClassEnv = inferClassEnv finalState-        let updatedPatternEnv = inferPatternEnv finalState-        let updatedPatternFuncEnv = inferPatternFuncEnv finalState-    -        -- Print type warnings if any-        when (not (null warnings)) $ do-          liftIO $ mapM_ (hPutStrLn stderr . formatTypeWarning) warnings-        -        -- Update type, class, and pattern environments in EvalState-        setTypeEnv updatedTypeEnv-        setClassEnv updatedClassEnv-        setPatternEnv updatedPatternEnv-        setPatternFuncEnv updatedPatternFuncEnv-        -        case result of-          Left err -> do-            liftIO $ hPutStrLn stderr $ "Type error:\n" ++ formatTypeError err-            -- Fallback: Use untyped evaluation if type checking fails (permissive mode)-            -- Type errors are handled immediately, not collected-            topExpr' <- desugarTopExpr expr-            case topExpr' of-              Nothing -> return ((bindings, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)-              Just topExpr'' -> do-                -- Evaluate type-error expressions immediately (not collected)-                -- This is a fallback for permissive mode-                case topExpr'' of-                  IDefine name expr ->-                    return ((bindings ++ [(name, expr)], patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)-                  IDefineMany defs ->-                    return ((bindings ++ defs, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)-                  IPatternFunctionDecl name _tyVars params _retType body ->-                    let paramNames = map fst params-                        patternFuncExpr = IPatternFuncExpr paramNames body-                    in return ((bindings, patFuncBindings ++ [(name, patternFuncExpr)], nonDefs), typedExprs, tiExprs, tcExprs)-                  _ ->-                    -- Non-definition: collect for later evaluation-                    return ((bindings, patFuncBindings, nonDefs ++ [(topExpr'', printValues)]), typedExprs, tiExprs, tcExprs) -          Right (Nothing, _subst) ->-            -- No code generated (e.g., load statements that are already processed)-            return ((bindings, patFuncBindings, nonDefs), typedExprs, tiExprs, tcExprs)-          -          Right (Just tiTopExpr, _subst) -> do-            -- Phase 7: inferITopExpr now returns TITopExpr directly-            -- No need for separate conversion--            -- Collect typed AST for --dump-typed (Phase 6: after type inference, before TypedDesugar)-            let typedExprs' = if optDumpTyped opts then typedExprs ++ [Just tiTopExpr] else typedExprs--            -- Phase 8a: TensorMap Insertion-            -- Insert tensorMap where needed (scalar vs tensor argument type conversion)-            mTiTopExprAfterTensorMap <- desugarTypedTopExprT_TensorMapOnly tiTopExpr--            case mTiTopExprAfterTensorMap of-              Nothing ->-                -- Load/LoadFile statements - no evaluation needed-                return ((bindings, patFuncBindings, nonDefs), typedExprs', tiExprs, tcExprs)--              Just tiTopExprAfterTensorMap -> do-                -- Collect TensorMap-inserted AST for --dump-ti (after TensorMap insertion)-                let tiExprs' = if optDumpTi opts then tiExprs ++ [Just tiTopExprAfterTensorMap] else tiExprs--                -- Phase 8b: Type Class Expansion-                -- Expand type class method calls to dictionary-based dispatch-                mTcTopExprAfterTypeClass <- desugarTypedTopExprT_TypeClassOnly tiTopExprAfterTensorMap+--------------------------------------------------------------------------------+-- Per-Expression Pipeline (Phases 3-8)+-------------------------------------------------------------------------------- -                case mTcTopExprAfterTypeClass of-                  Nothing ->-                    -- Load/LoadFile statements - no evaluation needed-                    return ((bindings, patFuncBindings, nonDefs), typedExprs', tiExprs', tcExprs)+processOneExpr :: EgisonOpts -> Bool -> Bool -> Set.Set String -> PipelineAccum -> TopExpr -> EvalM PipelineAccum+processOneExpr opts permissive printValues batchDefNames acc expr = do+  currentTypeEnv <- getTypeEnv+  currentClassEnv <- getClassEnv -                  Just tcTopExprAfterTypeClass -> do-                    -- Collect TypeClass-expanded AST for --dump-tc (after TypeClass expansion)-                    let tcExprs' = if optDumpTc opts then tcExprs ++ [Just tcTopExprAfterTypeClass] else tcExprs+  mITopExpr <- desugarTopExpr expr -                    -- Extract ITopExpr for evaluation-                    let iTopExprExpanded = stripTypeTopExpr tcTopExprAfterTypeClass+  case mITopExpr of+    Nothing -> return acc+    Just iTopExpr -> do+      -- Phase 5-6: Type Inference+      let inferConfig = (if permissive then permissiveInferConfig else defaultInferConfig)+                          { cfgMatcherConsistencyWarnings = optMatcherConsistencyWarnings opts }+      currentPatternEnv' <- getPatternEnv+      currentPatternFuncEnv' <- getPatternFuncEnv+      currentPatternFuncStructEnv' <- getPatternFuncStructEnv+      currentCasEdges <- getCasSubtypeEdges+      let patternFuncBindings = [(stringToVar name, scheme) | (name, scheme) <- patternEnvToList currentPatternFuncEnv']+          enrichedTypeEnv = extendEnvMany patternFuncBindings currentTypeEnv+          initState = (initialInferStateWithConfig inferConfig) {+            inferEnv = enrichedTypeEnv,+            inferClassEnv = currentClassEnv,+            inferPatternEnv = currentPatternEnv',+            inferPatternFuncEnv = currentPatternFuncEnv',+            inferPatternFuncStructEnv = currentPatternFuncStructEnv',+            inferCasSubtypeEdges = currentCasEdges,+            inferBatchDefNames = batchDefNames+          }+      (result, warnings, finalState) <- liftIO $+        runInferWithWarningsAndState (inferITopExpr iTopExpr) initState -                    -- Type scheme is already in the environment (added by inferITopExpr), no need to add again+      when (not (null warnings)) $+        liftIO $ mapM_ (hPutStrLn stderr . formatTypeWarning) warnings -                    -- Phase 9-10: Collect definitions and non-definitions-                    -- Definitions will be bound together using recursiveBind to support mutual recursion-                    -- Non-definitions will be evaluated sequentially after all definitions are bound-                    case iTopExprExpanded of-                      IDefine name expr ->-                        -- Collect definition for later binding-                        return ((bindings ++ [(name, expr)], patFuncBindings, nonDefs), typedExprs', tiExprs', tcExprs')-                      IDefineMany defs ->-                        -- Collect multiple definitions for later binding-                        return ((bindings ++ defs, patFuncBindings, nonDefs), typedExprs', tiExprs', tcExprs')-                      IPatternFunctionDecl name _tyVars params _retType body ->-                        -- Collect pattern function definition separately; it will be bound-                        -- into the pattern function environment (not the value environment)-                        -- via recursiveBindPatFuncs after all regular definitions are bound.-                        let paramNames = map fst params-                            patternFuncExpr = IPatternFuncExpr paramNames body-                        in return ((bindings, patFuncBindings ++ [(name, patternFuncExpr)], nonDefs), typedExprs', tiExprs', tcExprs')-                      _ ->-                        -- Non-definition expressions (ITest, IExecute)-                        -- Collect for evaluation after all definitions are bound-                        return ((bindings, patFuncBindings, nonDefs ++ [(iTopExprExpanded, printValues)]), typedExprs', tiExprs', tcExprs')-    ) (([], [], []), [], [], []) exprs+      setTypeEnv (inferEnv finalState)+      setClassEnv (inferClassEnv finalState)+      setPatternEnv (inferPatternEnv finalState)+      setPatternFuncEnv (inferPatternFuncEnv finalState)+      setPatternFuncStructEnv (inferPatternFuncStructEnv finalState) -  -- Dump typed AST BEFORE evaluation (so dumps are available even if evaluation fails)-  -- This is important for debugging - we want to see the typed AST even when there are runtime errors-  when (optDumpTyped opts && shouldDumpTyped) $ do-    dumpTyped typedExprs+      case result of+        Left err -> handleTypeError err acc expr printValues -  when (optDumpTi opts && shouldDumpTyped) $ do-    dumpTi tiExprs+        Right (Nothing, _subst) ->+          return acc -  when (optDumpTc opts && shouldDumpTyped) $ do-    dumpTc tcExprs+        Right (Just tiTopExpr, _subst) ->+          runTypedDesugaring opts acc tiTopExpr printValues -  -- Phase 9: Bind all regular value definitions and pattern function definitions-  -- together in a single step via recursiveBindAll so that every thunk is closed-  -- over a single environment that contains both regular values and pattern-  -- functions.  Regular values go into the normal env layers; pattern functions-  -- go into the separate PatFuncEnv.  This is necessary because ordinary-  -- definitions may contain matchAll expressions that invoke pattern functions.-  envWithPatFuncs <- recursiveBindAll env allBindings allPatFuncBindings+-- | Handle type error: fall back to untyped evaluation in permissive mode.+handleTypeError :: TypeError -> PipelineAccum -> TopExpr -> Bool -> EvalM PipelineAccum+handleTypeError err acc expr printValues = do+  liftIO $ hPutStrLn stderr $ "Type error:\n" ++ formatTypeError err+  topExpr' <- desugarTopExpr expr+  case topExpr' of+    Nothing      -> return acc+    Just iExpr   -> return $ classifyITopExpr iExpr printValues acc -  -- Phase 10: Evaluate non-definition expressions in order-  (lastVal, finalEnv) <- foldM (\(lastVal, currentEnv) (iExpr, shouldPrint) -> do-      evalResult <- catchError-        (Right <$> evalTopExpr' currentEnv iExpr)-        (\err -> do-          liftIO $ hPutStrLn stderr $ "Evaluation error: " ++ show err-          return $ Left err)+-- | Run TensorMap insertion and TypeClass expansion (Phase 7a-7b),+-- then classify the resulting ITopExpr.+runTypedDesugaring :: EgisonOpts -> PipelineAccum -> TITopExpr -> Bool -> EvalM PipelineAccum+runTypedDesugaring opts acc tiTopExpr printValues = do+  let acc1 = if optDumpTyped opts+             then acc { accumTypedExprs = accumTypedExprs acc ++ [Just tiTopExpr] }+             else acc -      case evalResult of-        Left _ -> return (lastVal, currentEnv)-        Right (mVal, env'') -> do-          when shouldPrint $ case mVal of-            Nothing -> return ()-            Just val -> valueToStr val >>= liftIO . putStrLn-          return (mVal, env'')-    ) (Nothing, envWithPatFuncs) nonDefExprs+  -- Phase 7a: TensorMap Insertion+  mAfterTensor <- desugarTypedTopExprT_TensorMapOnly tiTopExpr+  case mAfterTensor of+    Nothing -> return acc1+    Just afterTensor -> do+      let acc2 = if optDumpTi opts+                 then acc1 { accumTiExprs = accumTiExprs acc1 ++ [Just afterTensor] }+                 else acc1 -  return (lastVal, finalEnv)+      -- Phase 7b: Type Class Expansion+      mAfterTC <- desugarTypedTopExprT_TypeClassOnly afterTensor+      case mAfterTC of+        Nothing -> return acc2+        Just afterTC -> do+          let acc3 = if optDumpTc opts+                     then acc2 { accumTcExprs = accumTcExprs acc2 ++ [Just afterTC] }+                     else acc2+              iTopExprExpanded = stripTypeTopExpr afterTC+          return $ classifyITopExpr iTopExprExpanded printValues acc3  ----------------------------------------------------------------------------------- Phase 2 Helper: Environment Building (moved to EnvBuilder module)+-- Remaining public API ----------------------------------------------------------------------------------- | Evaluate an Egison top expression.+ evalTopExprStr :: Env -> TopExpr -> EvalM (Maybe String, Env) evalTopExprStr env topExpr = do   (val, env') <- evalTopExpr env topExpr@@ -387,27 +479,23 @@  valueToStr :: EgisonValue -> EvalM String valueToStr val = do-  mathExpr <- asks optMathExpr-  case mathExpr of+  mathValue <- asks optMathValue+  case mathValue of     Nothing   -> return (show val)     Just lang -> return (prettyMath lang val)  -- | Evaluate Egison top expressions.--- Pipeline: ExpandLoads → TypeCheck → TypedDesugar → Eval evalTopExprs :: Env -> [TopExpr] -> EvalM Env evalTopExprs env exprs = evalTopExprs' env exprs True True  -- | Evaluate Egison top expressions with control over printing and dumping. evalTopExprs' :: Env -> [TopExpr] -> Bool -> Bool -> EvalM Env evalTopExprs' env exprs printValues shouldDumpTyped = do-  -- Expand all Load/LoadFile recursively   expanded <- expandLoads exprs-  -- Evaluate using typed pipeline with printing   (_, env') <- evalExpandedTopExprsTyped' env expanded printValues shouldDumpTyped   return env'  -- | Evaluate Egison top expressions without printing.--- Pipeline: ExpandLoads → TypeCheck → TypedDesugar → Eval evalTopExprsNoPrint :: Env -> [TopExpr] -> EvalM Env evalTopExprsNoPrint env exprs = evalTopExprs' env exprs False True @@ -506,14 +594,38 @@   env' <- recursiveBindAll env bindings patFuncBindings   return (Nothing, env') evalTopExpr' env (IDeclareSymbol _names _mType) = do-  -- Symbol declarations are only used during type inference-  -- At runtime, they don't produce any value or modify the environment+  -- Symbols are pre-bound by `preBindDeclaredSymbols` before Phase 8 so+  -- that def closures (e.g. `def W := 1/(1-K*r^2)`) capture an env where+  -- the declared symbols are visible. This case is therefore a no-op.   return (Nothing, env) evalTopExpr' _env (IPatternFunctionDecl name _ _ _ _) = do-  -- Pattern function declarations are now handled via recursiveBind-  -- They should not reach here; this is a fallback   throwError $ Default $ "Pattern function " ++ name ++ " should have been converted to IPatternFuncExpr" +-- | Walk the input top exprs, collect every name from `declare symbol`,+-- and bind each to a CAS symbol value in the env. This MUST run before+-- Phase 8 (recursiveBindAll) so def closures capture an env in which the+-- declared symbols resolve correctly — particularly important for+-- uppercase names (`K`, `M`, `G`, …), which otherwise hit the+-- InductiveData fallback in `evalExprShallow env (IVarExpr name)` and+-- cause "Expected number, but found: K" at the first arithmetic use.+preBindDeclaredSymbols :: Env -> [TopExpr] -> EvalM Env+preBindDeclaredSymbols env exprs = do+  let names = concatMap collect exprs+  if null names+    then return env+    else do+      bindings <- mapM mkBinding names+      return $ extendEnv env bindings+  where+    collect :: TopExpr -> [String]+    collect (DeclareSymbol ns _) = ns+    collect _                    = []++    mkBinding :: String -> EvalM Binding+    mkBinding name = do+      ref <- liftIO $ newIORef (WHNF (Value (symbolCASData "" name)))+      return (stringToVar name, ref)+ -------------------------------------------------------------------------------- -- Environment Dumping --------------------------------------------------------------------------------@@ -559,7 +671,7 @@       else forM_ allInstances $ \(className, instInfo) -> do         let contextStr = if null (Types.instContext instInfo)               then ""-              else let showConstraint (Types.Constraint cls ty) = cls ++ " " ++ prettyType ty+              else let showConstraint (Types.Constraint cls tys) = cls ++ concatMap (\t -> " " ++ prettyType t) tys                    in intercalate ", " (map showConstraint (Types.instContext instInfo)) ++ " => "         putStrLn $ "  instance " ++ contextStr ++ className ++ " " ++ prettyType (Types.instType instInfo)     putStrLn ""@@ -615,49 +727,16 @@     putStrLn ""     putStrLn "=== End of Desugared AST ===" --- | Dump typed AST after Phase 6 (Type Inference & Check)-dumpTyped :: [Maybe TITopExpr] -> EvalM ()-dumpTyped typedExprs = do-  liftIO $ do-    putStrLn "=== Typed AST (Phase 5-6: Type Inference) ==="-    putStrLn ""-    if null typedExprs-      then putStrLn "  (none)"-      else forM_ (zip [1 :: Int ..] typedExprs) $ \(i :: Int, mExpr) ->-        case mExpr of-          Nothing -> putStrLn $ "  [" ++ show i ++ "] (skipped)"-          Just expr -> do-            putStrLn $ "  [" ++ show i ++ "] " ++ prettyStr expr-    putStrLn ""-    putStrLn "=== End of Typed AST ==="--dumpTi :: [Maybe TITopExpr] -> EvalM ()-dumpTi tiExprs = do-  liftIO $ do-    putStrLn "=== Typed AST after TensorMap Insertion (Phase 8a) ==="-    putStrLn ""-    if null tiExprs-      then putStrLn "  (none)"-      else forM_ (zip [1 :: Int ..] tiExprs) $ \(i :: Int, mExpr) ->-        case mExpr of-          Nothing -> putStrLn $ "  [" ++ show i ++ "] (skipped)"-          Just expr -> do-            putStrLn $ "  [" ++ show i ++ "] " ++ prettyStr expr-    putStrLn ""-    putStrLn "=== End of TensorMap Insertion AST ==="--dumpTc :: [Maybe TITopExpr] -> EvalM ()-dumpTc tcExprs = do-  liftIO $ do-    putStrLn "=== Typed AST after Type Class Expansion (Phase 8b) ==="-    putStrLn ""-    if null tcExprs-      then putStrLn "  (none)"-      else forM_ (zip [1 :: Int ..] tcExprs) $ \(i :: Int, mExpr) ->-        case mExpr of-          Nothing -> putStrLn $ "  [" ++ show i ++ "] (skipped)"-          Just expr -> do-            putStrLn $ "  [" ++ show i ++ "] " ++ prettyStr expr-    putStrLn ""-    putStrLn "=== End of Type Class Expansion AST ==="-+-- | Generic dump for typed AST phases (--dump-typed, --dump-ti, --dump-tc).+dumpPhaseExprs :: String -> String -> [Maybe TITopExpr] -> EvalM ()+dumpPhaseExprs header footer exprs = liftIO $ do+  putStrLn $ "=== " ++ header ++ " ==="+  putStrLn ""+  if null exprs+    then putStrLn "  (none)"+    else forM_ (zip [1 :: Int ..] exprs) $ \(i :: Int, mExpr) ->+      case mExpr of+        Nothing -> putStrLn $ "  [" ++ show i ++ "] (skipped)"+        Just expr -> putStrLn $ "  [" ++ show i ++ "] " ++ prettyStr expr+  putStrLn ""+  putStrLn $ "=== " ++ footer ++ " ==="

@@ -25,6 +25,7 @@  import qualified Data.HashMap.Strict              as HashMap import           Data.HashMap.Strict              (HashMap)+import qualified Data.Set                         as Set  import           Language.Egison.IExpr import           Language.Egison.Type.Types       (Type, TypeScheme)@@ -57,6 +58,39 @@   , classEnv       :: ClassEnv       -- ^ Class environment (for type inference)   , patternEnv     :: PatternTypeEnv -- ^ Pattern constructor environment (for type inference)   , patternFuncEnv :: PatternTypeEnv -- ^ Pattern function environment (for disambiguation)+  , patternFuncStructEnv :: PatternTypeEnv -- ^ Pattern function structural signatures (paper PATFUN-DEF):+                                       --   for each pattern function, the scheme of+                                       --   beta_1 -> ... -> beta_k -> tau_p_body, where beta_i is the+                                       --   structural index of parameter i and tau_p_body is the body's+                                       --   structural index.  Instantiated at application sites (PAT-APP)+                                       --   to propagate the arguments' structural indices into the result.+  , reductionRulesCount  :: Int      -- ^ Phase 7.4/7.5: number of `declare rule` declarations seen+  , derivativeRulesCount :: Int      -- ^ Phase 6.3: number of `declare derivative` declarations seen+  , reductionRuleNames   :: [String] -- ^ Names of named rules ("auto" rules are excluded)+  , derivativeRuleNames  :: [String] -- ^ Names of declared derivatives (the function names)+  , autoRuleVarNames     :: [String] -- ^ Phase 7.5: full var names of auto rules (e.g. "autoRule.0").+                                       --   Accumulated as `declare rule auto` declarations are desugared,+                                       --   used to rebuild `mathNormalize` to apply each rule in sequence.+  , autoRuleTriggers     :: [Set.Set String] -- ^ Trigger-symbol set per auto rule (parallel to autoRuleVarNames).+                                       --   Each entry is the set of literal symbols/functions referenced by+                                       --   the rule's LHS. Empty set means "no specific trigger" -> always run.+                                       --   Stored as Set already (not [String]) so iterateRulesCAS can read+                                       --   it once per call without per-call Set construction.+  , derivativesDesugared :: [String] -- ^ Phase 6.3: derivative names desugared so far (in declaration order).+                                       --   Each `declare derivative` redefines `chainPartialDiff` using only+                                       --   the names *up to and including* itself, avoiding forward references+                                       --   to derivatives declared later (which would emit warnings).+  , casTypeAliasEnv :: HashMap String Type -- ^ Phase alpha (extensible CAS tower):+                                       --   `declare cas-type` transparent aliases, name -> fully+                                       --   expanded Type. Persists across load batches so aliases+                                       --   declared in a library apply to later files.+  , casSubtypeEdges :: [(Type, Type)] -- ^ Phase beta: `declare cas-subtype` edges (alias-expanded,+                                       --   declaration order, redundant edges included for node+                                       --   bookkeeping). Persists across load batches.+  , declaredSymbolOrder :: [String]  -- ^ G3 (cas-simplification): CAS symbols in `declare symbol`+                                       --   declaration order (deduplicated).  DG1: symbols declared+                                       --   earlier rank lower in the monomial order used by+                                       --   `declare ideal`, i.e. they survive in normal forms.   }  initialEvalState :: EvalState@@ -68,6 +102,17 @@   , classEnv = emptyClassEnv   , patternEnv = emptyPatternEnv   , patternFuncEnv = emptyPatternEnv+  , patternFuncStructEnv = emptyPatternEnv+  , reductionRulesCount = 0+  , derivativeRulesCount = 0+  , reductionRuleNames = []+  , derivativeRuleNames = []+  , autoRuleVarNames = []+  , autoRuleTriggers = []+  , derivativesDesugared = []+  , casTypeAliasEnv = HashMap.empty+  , casSubtypeEdges = []+  , declaredSymbolOrder = []   }  class (Applicative m, Monad m) => MonadEval m where@@ -96,17 +141,62 @@   -- Pattern function environment operations   getPatternFuncEnv :: m PatternTypeEnv   setPatternFuncEnv :: PatternTypeEnv -> m ()+  -- Pattern function structural-signature environment operations (paper PATFUN-DEF/PAT-APP)+  getPatternFuncStructEnv :: m PatternTypeEnv+  setPatternFuncStructEnv :: PatternTypeEnv -> m ()+  -- Phase 7.4/7.5: reduction-rule and derivative-rule registration counts.+  -- Counts only — full data is held by EnvBuildResult during build phase+  -- and isn't currently threaded into the runtime state.+  getReductionRulesCount :: m Int+  setReductionRulesCount :: Int -> m ()+  getDerivativeRulesCount :: m Int+  setDerivativeRulesCount :: Int -> m ()+  getReductionRuleNames :: m [String]+  setReductionRuleNames :: [String] -> m ()+  getDerivativeRuleNames :: m [String]+  setDerivativeRuleNames :: [String] -> m ()+  -- Phase 7.5: auto-rule full var names (e.g. "autoRule.0", "autoRule.1").+  -- Used to rebuild `mathNormalize` per `declare rule auto`.+  getAutoRuleVarNames :: m [String]+  setAutoRuleVarNames :: [String] -> m ()+  appendAutoRuleVarName :: String -> m ()+  -- Trigger-symbol set per auto rule, parallel to autoRuleVarNames.+  -- Read by iterateRulesCAS via getAutoRuleTriggers (returns the cached+  -- Set list directly; no per-call construction).+  getAutoRuleTriggers :: m [Set.Set String]+  appendAutoRuleTriggers :: [String] -> m ()+  -- Phase 6.3: derivative names already desugared (in declaration order).+  -- Lets each `declare derivative` see only the derivatives that come at or+  -- before it, avoiding forward references in the generated chainPartialDiff.+  getDerivativesDesugared :: m [String]+  setDerivativesDesugared :: [String] -> m ()+  appendDerivativeDesugared :: String -> m ()+  -- G3 (cas-simplification): `declare symbol` declaration order for the+  -- `declare ideal` priority list.+  getDeclaredSymbolOrder :: m [String]+  appendDeclaredSymbols :: [String] -> m ()+  -- Phase alpha (extensible CAS tower): `declare cas-type` alias environment.+  getCasTypeAliasEnv :: m (HashMap String Type)+  setCasTypeAliasEnv :: HashMap String Type -> m ()+  -- Phase beta: `declare cas-subtype` edges.+  getCasSubtypeEdges :: m [(Type, Type)]+  setCasSubtypeEdges :: [(Type, Type)] -> m ()  instance Monad m => MonadEval (StateT EvalState m) where   pushFuncName name = do     st <- get     put $ st { funcNameStack = name : funcNameStack st }     return ()-  topFuncName = head . funcNameStack <$> get+  topFuncName = do+    stack <- funcNameStack <$> get+    case stack of+      (x:_) -> return x+      []    -> error "topFuncName: function name stack is empty"   popFuncName = do     st <- get-    put $ st { funcNameStack = tail $ funcNameStack st }-    return ()+    case funcNameStack st of+      (_:rest) -> put st { funcNameStack = rest }+      []       -> error "popFuncName: function name stack is empty"   getFuncNameStack = funcNameStack <$> get      getInstanceEnv = instanceEnv <$> get@@ -164,6 +254,69 @@     st <- get     put $ st { patternFuncEnv = env } +  getPatternFuncStructEnv = patternFuncStructEnv <$> get+  setPatternFuncStructEnv env = do+    st <- get+    put $ st { patternFuncStructEnv = env }++  getReductionRulesCount = reductionRulesCount <$> get+  setReductionRulesCount n = do+    st <- get+    put $ st { reductionRulesCount = n }++  getDerivativeRulesCount = derivativeRulesCount <$> get+  setDerivativeRulesCount n = do+    st <- get+    put $ st { derivativeRulesCount = n }++  getReductionRuleNames = reductionRuleNames <$> get+  setReductionRuleNames ns = do+    st <- get+    put $ st { reductionRuleNames = ns }++  getDerivativeRuleNames = derivativeRuleNames <$> get+  setDerivativeRuleNames ns = do+    st <- get+    put $ st { derivativeRuleNames = ns }++  getAutoRuleVarNames = autoRuleVarNames <$> get+  setAutoRuleVarNames ns = do+    st <- get+    put $ st { autoRuleVarNames = ns }+  appendAutoRuleVarName n = do+    st <- get+    put $ st { autoRuleVarNames = autoRuleVarNames st ++ [n] }++  getAutoRuleTriggers = autoRuleTriggers <$> get+  appendAutoRuleTriggers ts = do+    st <- get+    put $ st { autoRuleTriggers = autoRuleTriggers st ++ [Set.fromList ts] }++  getDerivativesDesugared = derivativesDesugared <$> get+  setDerivativesDesugared ns = do+    st <- get+    put $ st { derivativesDesugared = ns }+  appendDerivativeDesugared n = do+    st <- get+    put $ st { derivativesDesugared = derivativesDesugared st ++ [n] }++  getDeclaredSymbolOrder = declaredSymbolOrder <$> get+  appendDeclaredSymbols names = do+    st <- get+    let existing = declaredSymbolOrder st+        newNames = filter (`notElem` existing) names+    put $ st { declaredSymbolOrder = existing ++ newNames }++  getCasTypeAliasEnv = casTypeAliasEnv <$> get+  setCasTypeAliasEnv env = do+    st <- get+    put $ st { casTypeAliasEnv = env }++  getCasSubtypeEdges = casSubtypeEdges <$> get+  setCasSubtypeEdges es = do+    st <- get+    put $ st { casSubtypeEdges = es }+ instance (MonadEval m) => MonadEval (ExceptT e m) where   pushFuncName name = lift $ pushFuncName name   topFuncName = lift topFuncName@@ -184,6 +337,30 @@   setPatternEnv = lift . setPatternEnv   getPatternFuncEnv = lift getPatternFuncEnv   setPatternFuncEnv = lift . setPatternFuncEnv+  getPatternFuncStructEnv = lift getPatternFuncStructEnv+  setPatternFuncStructEnv = lift . setPatternFuncStructEnv+  getReductionRulesCount = lift getReductionRulesCount+  setReductionRulesCount = lift . setReductionRulesCount+  getDerivativeRulesCount = lift getDerivativeRulesCount+  setDerivativeRulesCount = lift . setDerivativeRulesCount+  getReductionRuleNames = lift getReductionRuleNames+  setReductionRuleNames = lift . setReductionRuleNames+  getDerivativeRuleNames = lift getDerivativeRuleNames+  setDerivativeRuleNames = lift . setDerivativeRuleNames+  getAutoRuleVarNames = lift getAutoRuleVarNames+  setAutoRuleVarNames = lift . setAutoRuleVarNames+  appendAutoRuleVarName = lift . appendAutoRuleVarName+  getAutoRuleTriggers = lift getAutoRuleTriggers+  appendAutoRuleTriggers = lift . appendAutoRuleTriggers+  getDerivativesDesugared = lift getDerivativesDesugared+  setDerivativesDesugared = lift . setDerivativesDesugared+  appendDerivativeDesugared = lift . appendDerivativeDesugared+  getDeclaredSymbolOrder = lift getDeclaredSymbolOrder+  appendDeclaredSymbols = lift . appendDeclaredSymbols+  getCasTypeAliasEnv = lift getCasTypeAliasEnv+  setCasTypeAliasEnv = lift . setCasTypeAliasEnv+  getCasSubtypeEdges = lift getCasSubtypeEdges+  setCasSubtypeEdges = lift . setCasSubtypeEdges  mLabelFuncName :: MonadEval m => Maybe Var -> m a -> m a mLabelFuncName Nothing m = m

@@ -35,6 +35,7 @@   , tipType   , stripType   , stripTypeTopExpr+  , mapTIExprChildren   , Var (..)   , stringToVar   , extractNameFromVar@@ -111,6 +112,24 @@   | IFlipIndicesExpr IExpr   | IFunctionExpr [String]   | IPatternFuncExpr [String] IPattern  -- Pattern function: parameter names and pattern body+  -- Type-driven structural reshape of a CAS value. Inserted by post-typecheck+  -- elaboration from a type annotation (`def x : T := e` becomes+  -- `IDefine x (IReshape T e)`). The Type argument is fixed at compile time;+  -- the actual structural rewrite runs at evaluation time via casReshapeAs.+  -- See design/type-cas-implementation-status.md.+  | IReshape Type IExpr+  -- Runtime-type dispatch: select an instance dictionary by inspecting the+  -- runtime CAS shape of the first argument. Emitted by TypeClassExpand when+  -- a method is called on a value whose static type is `MathValue` and no+  -- explicit `instance Class MathValue` exists. The (Type, String) list+  -- carries the candidate instance types together with their dictionary+  -- variable names; lookup happens at evaluation time. See+  -- design/runtime-type-dispatch.md.+  | IRuntimeDispatch+      String          -- class name (e.g. "Differentiable")+      String          -- method name (e.g. "partialDiff")+      [(Type, String)] -- candidates: (instance type, dict var name)+      [IExpr]         -- arguments (first one is the dispatch value)   deriving Show  type IBindingExpr = (IPrimitiveDataPattern, IExpr)@@ -210,9 +229,9 @@ -- -- Typed Internal Expressions ----------------------------------------------------------------------------------- Phase 9: TIExpr - Evaluatable Typed IR with Type Info Preserved+-- Phase 7 output: TIExpr - Typed IR with Type Info Preserved ----------------------------------------------------------------------------------- TIExpr is the result of Phase 8 (TypedDesugar) and input to Phase 10 (Evaluation).+-- TIExpr is the result of Phase 7 (TypedDesugar) and input to Phase 8-9 (Binding/Evaluation). -- It carries type information alongside the expression for: --   - Better runtime error messages with type information --   - Type-based dispatch during evaluation@@ -223,8 +242,8 @@ -- Type classes have already been resolved to dictionary passing, so no type class -- constraints are needed here. --- | Typed top-level expression (Phase 9: TITopExpr)--- Result of TypedDesugar phase, ready for evaluation.+-- | Typed top-level expression+-- Result of Phase 7 (TypedDesugar), ready for evaluation. data TITopExpr   = TIDefine TypeScheme Var TIExpr     -- ^ Typed definition with type scheme (includes type vars & constraints)   | TIDefineMany [(Var, TIExpr)]       -- ^ Multiple definitions (letrec)@@ -241,9 +260,9 @@     -- TIPattern: typed body   deriving Show --- | Typed internal expression (Phase 9: TIExpr)+-- | Typed internal expression (TIExpr) -- Each expression node carries its inferred/checked type scheme with type variables and constraints.--- TypeScheme info is preserved for Phase 8 (TypedDesugar) to perform type-driven transformations+-- TypeScheme info is preserved for Phase 7 (TypedDesugar) to perform type-driven transformations -- such as type class dictionary passing and tensorMap insertion. -- -- NEW: TIExpr is now RECURSIVE - each sub-expression is also a TIExpr,@@ -324,6 +343,14 @@      -- Function reference   | TIFunctionExpr [String]+  -- Reshape: typed mirror of IReshape. See note above.+  | TIReshape Type TIExpr+  -- Runtime-type dispatch: see `IRuntimeDispatch` in IExpr above.+  | TIRuntimeDispatch+      String           -- class name+      String           -- method name+      [(Type, String)] -- (instance type, dict var name) candidates+      [TIExpr]         -- arguments (first one is the dispatch value)   deriving Show  -- | Typed binding expression@@ -396,6 +423,9 @@   TITransposeExpr perm tensor -> ITransposeExpr (stripType perm) (stripType tensor)   TIFlipIndicesExpr tensor -> IFlipIndicesExpr (stripType tensor)   TIFunctionExpr names -> IFunctionExpr names+  TIReshape ty inner -> IReshape ty (stripType inner)+  TIRuntimeDispatch className methodName candidates args ->+    IRuntimeDispatch className methodName candidates (map stripType args)   where     stripTypeBinding :: TIBindingExpr -> IBindingExpr     stripTypeBinding (pat, expr) = (pat, stripType expr)@@ -482,6 +512,87 @@          stripTypeLoopRange :: TILoopRange -> ILoopRange     stripTypeLoopRange (TILoopRange e1 e2 pat) = ILoopRange (stripType e1) (stripType e2) (stripTypePat pat)++-- | Apply a function to all immediate TIExpr children of a TIExprNode.+-- Patterns are left untouched; use a separate pattern traversal if needed.+-- When adding a new TIExprNode constructor, add its case here to keep+-- all generic traversals (constraint resolution, etc.) working.+mapTIExprChildren :: (TIExpr -> TIExpr) -> TIExprNode -> TIExprNode+mapTIExprChildren f node = case node of+  -- Leaf nodes+  TIConstantExpr c        -> TIConstantExpr c+  TIVarExpr name          -> TIVarExpr name+  TIFunctionExpr names    -> TIFunctionExpr names++  -- Single child+  TILambdaExpr mVar ps body    -> TILambdaExpr mVar ps (f body)+  TIMemoizedLambdaExpr args body -> TIMemoizedLambdaExpr args (f body)+  TICambdaExpr var body         -> TICambdaExpr var (f body)+  TIWithSymbolsExpr syms body   -> TIWithSymbolsExpr syms (f body)+  TIQuoteExpr e                 -> TIQuoteExpr (f e)+  TIQuoteSymbolExpr e           -> TIQuoteSymbolExpr (f e)+  TITensorContractExpr e        -> TITensorContractExpr (f e)+  TIFlipIndicesExpr e           -> TIFlipIndicesExpr (f e)++  -- Two children+  TIConsExpr e1 e2               -> TIConsExpr (f e1) (f e2)+  TIJoinExpr e1 e2               -> TIJoinExpr (f e1) (f e2)+  TISeqExpr e1 e2                -> TISeqExpr (f e1) (f e2)+  TIGenerateTensorExpr fn sh     -> TIGenerateTensorExpr (f fn) (f sh)+  TITensorExpr sh el             -> TITensorExpr (f sh) (f el)+  TITensorMapExpr fn t           -> TITensorMapExpr (f fn) (f t)+  TITransposeExpr p t            -> TITransposeExpr (f p) (f t)+  TISubrefsExpr b e1 e2          -> TISubrefsExpr b (f e1) (f e2)+  TISuprefsExpr b e1 e2          -> TISuprefsExpr b (f e1) (f e2)+  TIUserrefsExpr b e1 e2         -> TIUserrefsExpr b (f e1) (f e2)++  -- Three children+  TIIfExpr c t e                    -> TIIfExpr (f c) (f t) (f e)+  TITensorMap2Expr fn t1 t2         -> TITensorMap2Expr (f fn) (f t1) (f t2)+  TITensorMap2WedgeExpr fn t1 t2    -> TITensorMap2WedgeExpr (f fn) (f t1) (f t2)++  -- List children+  TITupleExpr es           -> TITupleExpr (map f es)+  TICollectionExpr es      -> TICollectionExpr (map f es)+  TIVectorExpr es          -> TIVectorExpr (map f es)+  TIInductiveDataExpr n es -> TIInductiveDataExpr n (map f es)++  -- Function + args+  TIApplyExpr fn args      -> TIApplyExpr (f fn) (map f args)+  TIWedgeApplyExpr fn args -> TIWedgeApplyExpr (f fn) (map f args)++  -- Hash pairs+  TIHashExpr pairs -> TIHashExpr [(f k, f v) | (k, v) <- pairs]++  -- Bindings + body+  TILetExpr bs body    -> TILetExpr (mapBind f bs) (f body)+  TILetRecExpr bs body -> TILetRecExpr (mapBind f bs) (f body)+  TIDoExpr bs body     -> TIDoExpr (mapBind f bs) (f body)++  -- Pattern matching (expression children only; patterns are untouched)+  TIMatchExpr mode tgt mat cls ->+    TIMatchExpr mode (f tgt) (f mat) (mapClause f cls)+  TIMatchAllExpr mode tgt mat cls ->+    TIMatchAllExpr mode (f tgt) (f mat) (mapClause f cls)++  -- Matcher+  TIMatcherExpr pds ->+    TIMatcherExpr [(pat, f expr, mapBind f bs) | (pat, expr, bs) <- pds]++  -- Indexed+  TIIndexedExpr ov expr idxs ->+    TIIndexedExpr ov (f expr) (fmap f <$> idxs)++  -- Reshape: traverse the inner expression; type is metadata+  TIReshape ty inner ->+    TIReshape ty (f inner)++  -- Runtime dispatch: traverse arguments only; class/method/candidates are metadata+  TIRuntimeDispatch cls m cands args ->+    TIRuntimeDispatch cls m cands (map f args)+  where+    mapBind g  = map (\(p, e) -> (p, g e))+    mapClause g = map (\(p, e) -> (p, g e))  -- | Typed pattern with recursive structure (like TIExpr) data TIPattern = TIPattern

@@ -5,30 +5,66 @@ Licence     : MIT  This module provides the interface of Egison's computer algebra system.+This module provides the public API for Egison's computer algebra system based on CASValue. -}  module Language.Egison.Math-  ( ScalarData (..)-  , PolyExpr (..)-  , TermExpr (..)-  , Monomial-  , SymbolExpr (..)-  , Printable (..)-  , pattern ZeroExpr-  , pattern SingleSymbol-  , pattern SingleTerm-  , mathNormalize'-  , rewriteSymbol-  , mathPlus-  , mathMult-  , mathDiv-  , mathNumerator-  , mathDenominator-  , mathNegate-  , makeApplyExpr+  ( -- * CAS Public API+    CASValue (..)+  , CASTerm (..)+  , casNormalize+  , casRewriteSymbol+  , casPlus+  , casMinus+  , casMult+  , casDivide+  , casPower+  , casNumerator+  , casDenominator+  , casNegate+  , casIsZero+  , casIsAtom+    -- ** Pretty printing+  , prettyCAS+    -- ** CAS Pattern Synonyms+  , pattern CASZero+  , pattern CASSingleSymbol+  , pattern CASSingleTerm+    -- ** CAS Pattern Matching (control-egison)+  , CASM (..)+  , CASTermM (..)+  , CASSymbolM (..)+  , casTerm'+  , casTerm'M+  , casTermM+  , casSymbol+  , casSymbolM+  , casFunc+  , casFuncM+  , casApply1+  , casApply1M+  , casApply2+  , casApply2M+  , casApply3+  , casApply3M+  , casApply4+  , casApply4M+  , casQuote+  , casNegQuote+  , casNegQuoteM+  , casQuoteFunction+  , casQuoteFunctionM+  , casEqualMonomial+  , casEqualMonomialM+  , casZero+  , casZeroM+  , casSingleTerm+  , casSingleTermM   ) where -import           Language.Egison.Math.Arith-import           Language.Egison.Math.Expr-import           Language.Egison.Math.Normalize-import           Language.Egison.Math.Rewrite+import           Language.Egison.Math.CAS hiding (SymbolExpr(..), Monomial, makeApplyExpr)+import qualified Language.Egison.Math.Rewrite as R++-- | Apply rewrite rules to a CASValue (CAS version of rewriteSymbol)+casRewriteSymbol :: CASValue -> CASValue+casRewriteSymbol = R.casRewriteSymbol

@@ -1,51 +0,0 @@-{- |-Module      : Language.Egison.Math.Arith-Licence     : MIT--This module defines some basic arithmetic operations for Egison's computer-algebra system.--}--module Language.Egison.Math.Arith-  ( mathPlus-  , mathMinus-  , mathMult-  , mathDiv-  , mathPower-  , mathNumerator-  , mathDenominator-  ) where--import           Language.Egison.Math.Expr-import           Language.Egison.Math.Normalize--mathPlus :: ScalarData -> ScalarData -> ScalarData-mathPlus (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathPlusPoly (mathMultPoly m1 n2) (mathMultPoly m2 n1)) (mathMultPoly n1 n2)--mathPlusPoly :: PolyExpr -> PolyExpr -> PolyExpr-mathPlusPoly (Plus ts1) (Plus ts2) = Plus (ts1 ++ ts2)--mathMinus :: ScalarData -> ScalarData -> ScalarData-mathMinus s1 s2 = mathPlus s1 (mathNegate s2)--mathMult :: ScalarData -> ScalarData -> ScalarData-mathMult (Div m1 n1) (Div m2 n2) = mathNormalize' $ Div (mathMultPoly m1 m2) (mathMultPoly n1 n2)--mathMultPoly :: PolyExpr -> PolyExpr -> PolyExpr-mathMultPoly (Plus []) (Plus _)    = Plus []-mathMultPoly (Plus _) (Plus [])    = Plus []-mathMultPoly (Plus ts1) (Plus ts2) = foldl mathPlusPoly (Plus []) (map (\(Term a xs) -> Plus (map (\(Term b ys) -> Term (a * b) (xs ++ ys)) ts2)) ts1)--mathDiv :: ScalarData -> ScalarData -> ScalarData-mathDiv s (Div p1 p2) = mathMult s (Div p2 p1)--mathPower :: ScalarData -> Integer -> ScalarData-mathPower _ 0          = SingleTerm 1 []-mathPower s 1          = s-mathPower s n | n >= 2 = mathMult s (mathPower s (n - 1))--mathNumerator :: ScalarData -> ScalarData-mathNumerator (Div m _) = Div m (Plus [Term 1 []])--mathDenominator :: ScalarData -> ScalarData-mathDenominator (Div _ n) = Div n (Plus [Term 1 []])

@@ -0,0 +1,1477 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE QuasiQuotes           #-}++{- |+Module      : Language.Egison.Math.CAS+Licence     : MIT++This module defines the new CASValue data type for the computer algebra system.+The type structure directly determines the runtime internal representation.++Key design principles:+- Type composition determines normal form (e.g., Poly (Frac Integer) vs Frac (Poly Integer))+- Supports Laurent polynomials (negative exponents allowed in monomials)+- Constructive: coefficients can be recursively nested CASValues+-}++module Language.Egison.Math.CAS+    ( -- * Core data types+      CASValue (..)+    , CASTerm (..)+    , Monomial+    , SymbolExpr (..)+    , Id+    , makeApplyExpr+    -- * Smart constructors+    , casInteger+    , casFactor+    , casPoly+    , casFrac+    , casTerm+    -- * Arithmetic operations+    , casPlus+    , casMult+    , casNegate+    , casMinus+    , casDivide+    , casPower+    , casNumerator+    , casDenominator+    -- * Observed type (Phase 8)+    , prettyTypeOf+    , casAtomSet+    , casDifferentialClosed+    -- * Normalization+    , casNormalize+    , casNormalizePoly+    , casReshapeAs+    -- * Re-exports for Rewrite.hs (avoids a direct Data import cycle)+    , prettyFunctionName+    -- * Predicates+    , casIsZero+    , casIsAtom+    -- * Pretty printing+    , prettyCAS+    -- * GCD operations+    , casGcd+    , casTermsGcd+    -- * Pattern synonyms for CASValue+    , pattern CASZero+    , pattern CASSingleSymbol+    , pattern CASSingleTerm+    -- * Pattern matching (control-egison)+    , CASM (..)+    , CASTermM (..)+    , CASSymbolM (..)+    , casTerm'+    , casTerm'M+    , casTermM+    , casSymbol+    , casSymbolM+    , casFunc+    , casFuncM+    , casApply1+    , casApply1M+    , casApply2+    , casApply2M+    , casApply3+    , casApply3M+    , casApply4+    , casApply4M+    , casQuote+    , casNegQuote+    , casNegQuoteM+    , casQuoteFunction+    , casQuoteFunctionM+    , casEqualMonomial+    , casEqualMonomialM+    , casZero+    , casZeroM+    , casSingleTerm+    , casSingleTermM+    ) where++import           Data.List (sortBy, groupBy, intercalate, intersect, nub)+import           Data.Ord (comparing)+import           Data.Function (on)+import           Data.Ratio ((%), numerator, denominator)++import           Control.Egison+import           Control.Monad (MonadPlus (..))++import           Language.Egison.IExpr (Index (..))+import           Language.Egison.Type.Types (Type(..), SymbolSet(..), TypeAtom(..))+import {-# SOURCE #-} Language.Egison.Data (WHNFData, prettyFunctionName)++-- | CASValue represents mathematical values in the CAS.+-- The structure is compositional: each constructor has a well-defined semantics.+data CASValue+  = CASInteger Integer+    -- ^ Base case: an integer value+  | CASFactor SymbolExpr+    -- ^ An atomic factor (generated by quote operator ')+    -- Represents a symbol or function application that is not yet expanded+  | CASPoly [CASTerm]+    -- ^ A polynomial (sum of terms). Empty list represents zero.+    -- Supports Laurent polynomials: monomial exponents can be negative.+  | CASFrac CASValue CASValue+    -- ^ A quotient: numerator / denominator+    -- Only needed when denominator is non-monomial+  deriving (Eq, Show)++-- | CASTerm represents a single term in a polynomial: coefficient × monomial+-- The coefficient is a CASValue, enabling nested polynomial structures.+data CASTerm = CASTerm CASValue Monomial+  deriving (Eq, Show)++-- | 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)]++-- | Identifier type for symbols+type Id = String++-- | SymbolExpr represents atomic symbolic expressions in the CAS.+-- NOTE: SymbolExpr uses CASValue for function arguments (Apply1-4, Quote, FunctionData).+data SymbolExpr+  = Symbol Id String [Index CASValue]+  | Apply1 CASValue CASValue+  | Apply2 CASValue CASValue CASValue+  | Apply3 CASValue CASValue CASValue CASValue+  | Apply4 CASValue CASValue CASValue CASValue CASValue+  | Quote CASValue                     -- For backtick quote: `expr+  | QuoteFunction WHNFData             -- For single quote on functions: 'func+  | FunctionData CASValue [CASValue]   -- fnname args++-- Manual Eq instance (QuoteFunction comparison uses function name)+instance Eq SymbolExpr where+  Symbol id1 s1 js1 == Symbol id2 s2 js2 = id1 == id2 && s1 == s2 && js1 == js2+  Apply1 f1 a1 == Apply1 f2 a2 = f1 == f2 && a1 == a2+  Apply2 f1 a1 b1 == Apply2 f2 a2 b2 = f1 == f2 && a1 == a2 && b1 == b2+  Apply3 f1 a1 b1 c1 == Apply3 f2 a2 b2 c2 = f1 == f2 && a1 == a2 && b1 == b2 && c1 == c2+  Apply4 f1 a1 b1 c1 d1 == Apply4 f2 a2 b2 c2 d2 = f1 == f2 && a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2+  Quote m1 == Quote m2 = m1 == m2+  QuoteFunction whnf1 == QuoteFunction whnf2 =+    case (prettyFunctionName whnf1, prettyFunctionName whnf2) of+      (Just n1, Just n2) -> n1 == n2+      _ -> False  -- Anonymous functions are never equal+  FunctionData n1 k1 == FunctionData n2 k2 = n1 == n2 && k1 == k2+  _ == _ = False++instance Show SymbolExpr where+  show = prettySymbolExpr++-- | Pretty print a SymbolExpr+prettySymbolExpr :: SymbolExpr -> String+prettySymbolExpr (Symbol _ (':':':':':':_) []) = "#"+prettySymbolExpr (Symbol _ s [])               = s+prettySymbolExpr (Symbol _ s js)               = s ++ concatMap showIndex js+  where+    showIndex (Sup i)    = "~" ++ prettyCAS' i+    showIndex (Sub i)    = "_" ++ prettyCAS' i+    showIndex (SupSub i) = "~_" ++ prettyCAS' i+    showIndex (DF _ _)   = ""+    showIndex (User i)   = "|" ++ prettyCAS' i+prettySymbolExpr (Apply1 fn a1)                = unwords [prettyApplyFn fn, prettyApplyArg a1]+prettySymbolExpr (Apply2 fn a1 a2)             = unwords [prettyApplyFn fn, prettyApplyArg a1, prettyApplyArg a2]+prettySymbolExpr (Apply3 fn a1 a2 a3)          = unwords [prettyApplyFn fn, prettyApplyArg a1, prettyApplyArg a2, prettyApplyArg a3]+prettySymbolExpr (Apply4 fn a1 a2 a3 a4)       = unwords [prettyApplyFn fn, prettyApplyArg a1, prettyApplyArg a2, prettyApplyArg a3, prettyApplyArg a4]+prettySymbolExpr (Quote mExprs)                = "`" ++ prettyCAS' mExprs+prettySymbolExpr (QuoteFunction whnf)          = "'" ++ maybe "<function>" id (prettyFunctionName whnf)+prettySymbolExpr (FunctionData name args)      = unwords (prettyApplyFn name : map prettyApplyArg args)++-- | Pretty print the function slot of an Apply1-4 / FunctionData. The function+-- reference is often stored as a CASPoly wrapper around a single CASFactor+-- (e.g. `'cos` is `CASPoly [CASTerm 1 [(QuoteFunction cos, 1)]]`); print such+-- wrappers transparently as the underlying SymbolExpr to avoid a spurious+-- `('cos) (θ)` rendering.+prettyApplyFn :: CASValue -> String+prettyApplyFn (CASFactor sym) = prettySymbolExpr sym+prettyApplyFn (CASPoly [CASTerm (CASInteger 1) [(sym, 1)]]) = prettySymbolExpr sym+prettyApplyFn v = prettyCAS' v++-- | Pretty print an argument to an Apply or FunctionData. Single-symbol+-- arguments (lifted to CASPoly with coefficient 1) print without parens+-- (e.g. `'cos θ` instead of `'cos (θ)`); composite arguments fall back to+-- the parenthesizing `prettyCAS'`.+prettyApplyArg :: CASValue -> String+prettyApplyArg (CASFactor sym) = prettySymbolExpr sym+prettyApplyArg (CASPoly [CASTerm (CASInteger 1) [(sym, 1)]]) = prettySymbolExpr sym+prettyApplyArg v = prettyCAS' v++-- | Pretty print a CASValue (basic version for SymbolExpr Show instance)+prettyCAS :: CASValue -> String+prettyCAS (CASInteger n) = show n+prettyCAS (CASFactor sym) = prettySymbolExpr sym+prettyCAS (CASPoly []) = "0"+prettyCAS (CASPoly terms) = prettyTerms terms+  where+    prettyTerms [] = "0"+    prettyTerms (t:ts) = prettyTerm t ++ concatMap withSign ts+    withSign term@(CASTerm coeff _)+      | isNegative coeff = " - " ++ prettyTerm (negateCAST term)+      | otherwise = " + " ++ prettyTerm term+    prettyTerm (CASTerm coeff []) = prettyCAS coeff+    prettyTerm (CASTerm (CASInteger 1) mono) = prettyMono mono+    prettyTerm (CASTerm (CASInteger (-1)) mono) = "- " ++ prettyMono mono+    -- Use the parenthesizing `prettyCAS'` for the coefficient so that nested+    -- polynomial coefficients (e.g. `(2*z + 3) * x`) don't visually flatten+    -- into the surrounding sum. Integer/Factor coeffs pass through unwrapped.+    prettyTerm (CASTerm coeff mono) = prettyCAS' coeff ++ " * " ++ prettyMono mono+    -- For multi-factor monomials, use ` * ` between factors when any is a+    -- function-application form (Apply1-4 / FunctionData), since juxtaposition+    -- would be ambiguous with the function-call syntax `f x`. Otherwise keep+    -- the conventional `x y` juxtaposition for plain symbols. A single factor+    -- needs no separator nor wrapping.+    prettyMono [single] = prettyPow single+    prettyMono mono+      | any (isApplyFactor . fst) mono = intercalate " * " (map prettyPow' mono)+      | otherwise                      = unwords (map prettyPow mono)+    -- prettyPow' wraps Apply factors in parens for clarity in the explicit-`*`+    -- form (e.g. `('cos θ) * r`).+    prettyPow' (sym, 1) | isApplyFactor sym = "(" ++ prettySymbolExpr sym ++ ")"+    prettyPow' p = prettyPow p+    prettyPow (sym, 1) = prettySymbolExpr sym+    -- An application form under an exponent needs parens: `g x y^2` would+    -- read as g applied to x and y^2, not as (g x y) squared.+    prettyPow (sym, n)+      | isApplyFactor sym = "(" ++ prettySymbolExpr sym ++ ")^" ++ show n+      | otherwise         = prettyCAS' (CASFactor sym) ++ "^" ++ show n+    isApplyFactor :: SymbolExpr -> Bool+    isApplyFactor (Apply1 {})       = True+    isApplyFactor (Apply2 {})       = True+    isApplyFactor (Apply3 {})       = True+    isApplyFactor (Apply4 {})       = True+    isApplyFactor (FunctionData {}) = True+    isApplyFactor _                 = False+    isNegative (CASInteger n) = n < 0+    isNegative _ = False+    negateCAST (CASTerm (CASInteger n) m) = CASTerm (CASInteger (-n)) m+    negateCAST t = t+prettyCAS (CASFrac num denom) = prettyCAS' num ++ " / " ++ prettyCAS' denom++prettyCAS' :: CASValue -> String+prettyCAS' v@(CASInteger _) = prettyCAS v+prettyCAS' v@(CASFactor _) = prettyCAS v+prettyCAS' v = "(" ++ prettyCAS v ++ ")"++-- | Compute the observed type of a CASValue and pretty print it.+-- The observed type is the most specific static type that the value+-- inhabits, computed bottom-up from the runtime structure.+--   CASInteger _      → "Integer"+--   CASFactor (Symbol ...)+--                     → "Symbol"+--   CASFactor _       → "Factor"+--   CASPoly []        → "Integer"   (canonical zero)+--   CASPoly terms     → "Poly C [atoms]" where C is the join of term coefficient+--                       types and atoms is the sorted list of distinct flat atoms+--   CASFrac n d       → "Frac (typeOf n)" if d is integer/poly with single term,+--                       otherwise "Frac (Poly typeOf-num [..])"+prettyTypeOf :: CASValue -> String+prettyTypeOf (CASInteger _) = "Integer"+prettyTypeOf (CASFactor (Symbol _ _ _)) = "Symbol"+prettyTypeOf (CASFactor _) = "Factor"+prettyTypeOf (CASPoly []) = "Integer"+prettyTypeOf (CASPoly terms) =+  let coeffTypes = map (\(CASTerm c _) -> prettyTypeOf c) terms+      coeffType  = joinObservedTypes coeffTypes+      atoms      = collectAtoms terms+      atomStr    = if null atoms+                     then "[]"+                     else "[" ++ commaSep atoms ++ "]"+   in "Poly " ++ parenIfApp coeffType ++ " " ++ atomStr+prettyTypeOf (CASFrac n d) =+  "Frac " ++ parenIfApp inner+  where+    nT = prettyTypeOf n+    dT = prettyTypeOf d+    -- If numerator and denominator share the observed type, that's the inner;+    -- otherwise widen to MathValue.+    inner = if nT == dT then nT else "MathValue"++-- | Pretty join of observed types of multiple coefficients.+--+-- "Integer" is the bottom of the CAS observed-type lattice (it embeds into+-- every other CAS type), so when one term is observed as "Integer" and the+-- rest as some richer type T, we report T (not the over-broad "MathValue").+-- If two truly distinct non-Integer types appear, we still widen to+-- "MathValue" — a full subtype-aware join over the observed-type strings is+-- left as future work.+joinObservedTypes :: [String] -> String+joinObservedTypes []  = "Integer"+joinObservedTypes ts  = case filter (/= "Integer") ts of+  []                        -> "Integer"+  t : ts' | all (== t) ts'  -> t+          | otherwise       -> "MathValue"++-- | Phase 8 differential closure: collect the set of atoms (as their canonical+-- pretty form) appearing in a CASValue's monomials, recursing into nested+-- coefficients. The result is a sorted list of unique atom names.+casAtomSet :: CASValue -> [String]+casAtomSet (CASInteger _) = []+casAtomSet (CASFactor sym) = [prettySymbolExpr sym]+casAtomSet (CASPoly terms) =+  let atomNames = concat+        [ map (prettySymbolExpr . fst) mono ++ casAtomSet coeff+        | CASTerm coeff mono <- terms+        ]+  in unique (sortBy compare atomNames)+  where+    unique [] = []+    unique (x:xs) = x : unique (dropWhile (== x) xs)+casAtomSet (CASFrac n d) =+  let combined = casAtomSet n ++ casAtomSet d+  in unique (sortBy compare combined)+  where+    unique [] = []+    unique (x:xs) = x : unique (dropWhile (== x) xs)++-- | Check whether differentiation preserved the atom set of the input.+-- Used by the `differentialClosed` primitive: the result is true iff the+-- atom set of `output` is a subset of that of `input` (no new atoms+-- introduced by `∂/∂`).+casDifferentialClosed :: CASValue -> CASValue -> Bool+casDifferentialClosed input output =+  let inA  = casAtomSet input+      outA = casAtomSet output+  in all (`elem` inA) outA++-- | Collect distinct atom names from a list of CASTerm monomials.+-- Returns a sorted list of pretty atom forms (`x`, `sin x`, etc.).+collectAtoms :: [CASTerm] -> [String]+collectAtoms terms =+  let atomNames = [prettySymbolExpr s | CASTerm _ mono <- terms, (s, _) <- mono]+  in unique (sortBy compare atomNames)+  where+    unique [] = []+    unique (x:xs) = x : unique (dropWhile (== x) xs)++-- | Comma-separate strings.+commaSep :: [String] -> String+commaSep []     = ""+commaSep [x]    = x+commaSep (x:xs) = x ++ ", " ++ commaSep xs++-- | Wrap in parens if the type printed contains a space (i.e. an application).+parenIfApp :: String -> String+parenIfApp s+  | ' ' `elem` s = "(" ++ s ++ ")"+  | otherwise    = s++-- | Helper function to create Apply constructors based on argument count+makeApplyExpr :: CASValue -> [CASValue] -> SymbolExpr+makeApplyExpr fn [a1] = Apply1 fn a1+makeApplyExpr fn [a1, a2] = Apply2 fn a1 a2+makeApplyExpr fn [a1, a2, a3] = Apply3 fn a1 a2 a3+makeApplyExpr fn [a1, a2, a3, a4] = Apply4 fn a1 a2 a3 a4+makeApplyExpr _ _ = error "makeApplyExpr: unsupported number of arguments (must be 1-4)"++--------------------------------------------------------------------------------+-- Smart Constructors+--------------------------------------------------------------------------------++-- | Create an integer CASValue+casInteger :: Integer -> CASValue+casInteger = CASInteger++-- | Create a factor CASValue from a SymbolExpr+casFactor :: SymbolExpr -> CASValue+casFactor = CASFactor++-- | Create a polynomial CASValue, normalizing the terms+casPoly :: [CASTerm] -> CASValue+casPoly terms = casNormalize (CASPoly terms)++-- | Create a division CASValue, simplifying if possible+casFrac :: CASValue -> CASValue -> CASValue+casFrac num denom = casNormalize (CASFrac num denom)++-- | Create a term+casTerm :: CASValue -> Monomial -> CASTerm+casTerm = CASTerm++--------------------------------------------------------------------------------+-- Predicates+--------------------------------------------------------------------------------++-- | Check if a CASValue is zero+casIsZero :: CASValue -> Bool+casIsZero (CASInteger 0) = True+casIsZero (CASPoly [])   = True+casIsZero (CASFrac n _)   = casIsZero n+casIsZero _              = False++-- | Check if a CASValue is one+casIsOne :: CASValue -> Bool+casIsOne (CASInteger 1)                     = True+casIsOne (CASPoly [CASTerm (CASInteger 1) []]) = True+casIsOne _                                  = False++-- | Check if a CASValue is atomic (no parentheses needed for display)+-- Returns True for atomic values that don't need parentheses for display+casIsAtom :: CASValue -> Bool+casIsAtom (CASInteger _) = True+casIsAtom (CASFactor _)  = True+casIsAtom (CASPoly [])   = True   -- Zero+casIsAtom (CASPoly [CASTerm _ []])  = True   -- Integer only+casIsAtom (CASPoly [CASTerm (CASInteger 1) [_]]) = True  -- Single symbol with coeff 1+casIsAtom (CASFrac num (CASPoly [CASTerm (CASInteger 1) []])) = casIsAtom num  -- n/1 = n+casIsAtom _ = False++--------------------------------------------------------------------------------+-- Arithmetic Operations+--------------------------------------------------------------------------------++-- | Add two CASValues+casPlus :: CASValue -> CASValue -> CASValue+casPlus a b = casNormalize (casPlus' a b)++casPlus' :: CASValue -> CASValue -> CASValue+-- Integer + Integer+casPlus' (CASInteger a) (CASInteger b) = CASInteger (a + b)++-- Poly + Poly+casPlus' (CASPoly ts1) (CASPoly ts2) = CASPoly (ts1 ++ ts2)++-- Integer + Poly: embed integer as polynomial term+casPlus' (CASInteger n) (CASPoly ts) = CASPoly (CASTerm (CASInteger n) [] : ts)+casPlus' (CASPoly ts) (CASInteger n) = CASPoly (CASTerm (CASInteger n) [] : ts)++-- Frac + Frac: cross-multiply and add numerators+casPlus' (CASFrac n1 d1) (CASFrac n2 d2) =+  CASFrac (casPlus' (casMult' n1 d2) (casMult' n2 d1)) (casMult' d1 d2)++-- Frac + other: embed other as Frac+casPlus' (CASFrac n d) other = CASFrac (casPlus' n (casMult' other d)) d+casPlus' other (CASFrac n d) = CASFrac (casPlus' (casMult' other d) n) d++-- Factor handling: lift to polynomial before operation+casPlus' (CASFactor sym) other = casPlus' (liftFactorToPoly sym) other+casPlus' other (CASFactor sym) = casPlus' other (liftFactorToPoly sym)++-- | Negate a CASValue+casNegate :: CASValue -> CASValue+casNegate (CASInteger n)  = CASInteger (-n)+casNegate (CASPoly terms) = CASPoly (map negateTerm terms)+  where+    negateTerm (CASTerm coeff mono) = CASTerm (casNegate coeff) mono+casNegate (CASFrac n d)    = CASFrac (casNegate n) d+casNegate (CASFactor sym) = CASPoly [CASTerm (CASInteger (-1)) [(sym, 1)]]++-- | Subtract two CASValues+casMinus :: CASValue -> CASValue -> CASValue+casMinus a b = casPlus a (casNegate b)++-- | Multiply two CASValues+casMult :: CASValue -> CASValue -> CASValue+casMult a b = casNormalize (casMult' a b)++casMult' :: CASValue -> CASValue -> CASValue+-- Integer * Integer+casMult' (CASInteger a) (CASInteger b) = CASInteger (a * b)++-- Integer * Poly: scale all coefficients+casMult' (CASInteger n) (CASPoly ts) = CASPoly (map (scaleTerm n) ts)+  where+    scaleTerm k (CASTerm coeff mono) = CASTerm (casMult' (CASInteger k) coeff) mono+casMult' (CASPoly ts) (CASInteger n) = casMult' (CASInteger n) (CASPoly ts)++-- Poly * Poly: distribute+casMult' (CASPoly []) _ = CASPoly []+casMult' _ (CASPoly []) = CASPoly []+casMult' (CASPoly ts1) (CASPoly ts2) =+  CASPoly [multTerms t1 t2 | t1 <- ts1, t2 <- ts2]+  where+    multTerms (CASTerm c1 m1) (CASTerm c2 m2) =+      CASTerm (casMult' c1 c2) (combineMonomials m1 m2)++-- Frac * Frac: multiply numerators and denominators+casMult' (CASFrac n1 d1) (CASFrac n2 d2) =+  CASFrac (casMult' n1 n2) (casMult' d1 d2)++-- Frac * other: multiply into numerator+casMult' (CASFrac n d) other = CASFrac (casMult' n other) d+casMult' other (CASFrac n d) = CASFrac (casMult' other n) d++-- Factor handling: lift to polynomial before operation+casMult' (CASFactor sym) other = casMult' (liftFactorToPoly sym) other+casMult' other (CASFactor sym) = casMult' other (liftFactorToPoly sym)++-- | Lift a Factor to a polynomial: sym → 1 * sym^1+liftFactorToPoly :: SymbolExpr -> CASValue+liftFactorToPoly sym = CASPoly [CASTerm (CASInteger 1) [(sym, 1)]]++-- | Combine two monomials by adding exponents of matching symbols+combineMonomials :: Monomial -> Monomial -> Monomial+combineMonomials m1 m2 = foldr insertSymbol m2 m1+  where+    insertSymbol (sym, expo) mono =+      case lookup sym mono of+        Just _  -> map (\(s, e) -> if s == sym then (s, e + expo) else (s, e)) mono+        Nothing -> (sym, expo) : mono++-- | Divide two CASValues: a / b+casDivide :: CASValue -> CASValue -> CASValue+casDivide a b = casNormalize (CASFrac a b)++-- | Raise a CASValue to an integer power+casPower :: CASValue -> Integer -> CASValue+casPower _ 0 = CASInteger 1+casPower x 1 = x+casPower x n+  | n > 0     = casMult x (casPower x (n - 1))+  | otherwise = casDivide (CASInteger 1) (casPower x (-n))  -- Negative power++-- | Get the numerator of a CASValue.+-- For tower-fixed level 4 polynomials (Poly with Frac coefficients),+-- compute the LCM of coefficient denominators and return the value+-- multiplied by it (clearing the Fracs from coefficients).+casNumerator :: CASValue -> CASValue+casNumerator (CASFrac num _) = num+casNumerator x@(CASPoly ts) =+  let lcmD = polyDenominatorLCM ts+  in if lcmD == 1+     then x+     else casMult x (CASInteger lcmD)+casNumerator x              = x++-- | Get the denominator of a CASValue.+-- For tower-fixed level 4 polynomials, the denominator is the LCM of+-- the Frac coefficients' denominators.+casDenominator :: CASValue -> CASValue+casDenominator (CASFrac _ denom) = denom+casDenominator (CASPoly ts) = CASInteger (polyDenominatorLCM ts)+casDenominator _                = CASInteger 1++-- | Compute the LCM of all denominators in a polynomial's Frac coefficients.+-- Returns 1 if there are no Frac coefficients.+polyDenominatorLCM :: [CASTerm] -> Integer+polyDenominatorLCM ts =+  let denoms = concatMap termDenoms ts+  in if null denoms then 1 else foldl1 lcm denoms+  where+    termDenoms (CASTerm (CASFrac _ (CASInteger d)) _) = [abs d]+    termDenoms _                                       = []++--------------------------------------------------------------------------------+-- Normalization+--------------------------------------------------------------------------------++-- | Normalize a CASValue+casNormalize :: CASValue -> CASValue+casNormalize (CASInteger n) = CASInteger n+casNormalize (CASFactor sym) = CASFactor sym+casNormalize (CASPoly terms) = casNormalizePoly terms+casNormalize (CASFrac num denom) = casNormalizeFrac num denom++-- | Normalize a polynomial+-- Steps:+-- 1. Fold symbols within each term (x * x^2 → x^3)+-- 2. Remove zero-exponent symbols+-- 3. Fold terms with equal monomials+-- 4. Remove zero-coefficient terms+-- 5. Sort terms in descending order+casNormalizePoly :: [CASTerm] -> CASValue+casNormalizePoly = casNormalizePolyWith FlattenNested++-- | How polynomial normalization treats nested coefficients (Phase+-- gamma-prime of the extensible-tower plan,+-- design/type-cas-tower-implementation.md section 4).+data NestedCoeffPolicy+  = FlattenNested+    -- ^ The default on every arithmetic path: a coefficient that is itself+    -- a CASPoly (the nested canonical form produced by reshape) is+    -- distributed out into the outer monomial, so operations always exit+    -- in the default flat canonical form and terms coming from nested and+    -- flat representations merge (i + (-i) = 0 across representations).+  | KeepNested+    -- ^ Reshape's final grouping: keep the nested form just constructed.+    -- Coefficients are neither re-normalized (they were just produced by a+    -- recursive reshape; re-normalizing would flatten deeper nesting) nor+    -- distributed. Invariant: nested forms exist only as the direct output+    -- of reshape (annotation sites).+  deriving (Eq)++-- | Core polynomial normalization, parametrized by the nested-coefficient+-- policy (see 'NestedCoeffPolicy').+casNormalizePolyWith :: NestedCoeffPolicy -> [CASTerm] -> CASValue+casNormalizePolyWith policy terms =+  let flatten = policy == FlattenNested+      -- Normalize each term's monomial+      terms1 = map (normalizeTermMonomialWith flatten) terms+      -- Distribute nested coefficients (flat exit form) when asked to+      terms1' = if flatten && any hasNestedCoeff terms1+                  then map (normalizeTermMonomialWith flatten)+                           (concatMap flattenNestedTerm terms1)+                  else terms1+      -- Fold terms with equal monomials+      terms2 = foldTermsWith policy terms1'+      -- Remove zero-coefficient terms+      terms3 = filter (not . isZeroTerm) terms2+      -- Sort in descending order (standard polynomial order)+      terms4 = sortTermsDescending terms3+  in case terms4 of+       []  -> CASInteger 0  -- Empty polynomial is zero+       [CASTerm coeff []] | isIntegerCoeff coeff -> extractInteger coeff+       ts  -> CASPoly ts+  where+    isZeroTerm (CASTerm coeff _) = casIsZero coeff+    isIntegerCoeff (CASInteger _) = True+    isIntegerCoeff _ = False+    extractInteger (CASInteger n) = CASInteger n+    extractInteger _ = error "extractInteger: not an integer"++-- | Does the term carry a nested coefficient that 'flattenNestedTerm'+-- would distribute? Cheap constructor check used as a fast-path guard.+hasNestedCoeff :: CASTerm -> Bool+hasNestedCoeff (CASTerm (CASPoly _) _) = True+hasNestedCoeff (CASTerm (CASFrac (CASPoly _) (CASInteger _)) _) = True+hasNestedCoeff _ = False++-- | Distribute a nested coefficient into flat terms: a CASPoly coefficient+-- is multiplied out into the outer monomial; a CASFrac coefficient with a+-- CASPoly numerator over an integer denominator is distributed likewise.+-- Recursion terminates because each step strictly reduces nesting.+flattenNestedTerm :: CASTerm -> [CASTerm]+flattenNestedTerm t@(CASTerm c mono) = case c of+  CASPoly inner ->+    concatMap (\(CASTerm ic im) -> flattenNestedTerm (CASTerm ic (im ++ mono))) inner+  CASFrac (CASPoly inner) d@(CASInteger _) ->+    concatMap (\(CASTerm ic im) ->+                 flattenNestedTerm (CASTerm (casNormalizeFrac ic d) (im ++ mono))) inner+  _ -> [t]++-- | Normalize a term's monomial: combine duplicate symbols, remove zero+-- exponents. When `renormCoeff` is False the coefficient is left untouched+-- (reshape's keep-nested mode — the coefficient was just built by a+-- recursive reshape and re-normalizing it would flatten deeper nesting).+normalizeTermMonomialWith :: Bool -> CASTerm -> CASTerm+normalizeTermMonomialWith renormCoeff (CASTerm coeff mono) =+  let -- Fold duplicate symbols+      mono1 = foldMonomialSymbols mono+      -- Remove zero-exponent symbols+      mono2 = filter (\(_, exp) -> exp /= 0) mono1+      -- Normalize the coefficient recursively (flatten mode only)+      coeff' = if renormCoeff then casNormalize coeff else coeff+  in CASTerm coeff' mono2++-- | Fold duplicate symbols in a monomial by adding their exponents+foldMonomialSymbols :: Monomial -> Monomial+foldMonomialSymbols mono =+  let grouped = groupBy ((==) `on` fst) (sortBy (comparing (show . fst)) mono)+  in concatMap combineGroup grouped+  where+    combineGroup :: [(SymbolExpr, Integer)] -> [(SymbolExpr, Integer)]+    combineGroup [] = []+    combineGroup grp@((sym, _):_) = [(sym, sum (map snd grp))]++-- | Fold terms with equal monomials by adding their coefficients; under+-- 'KeepNested' merged coefficients are normalized without flattening, so a+-- nested coefficient produced by reshape survives the grouping.+foldTermsWith :: NestedCoeffPolicy -> [CASTerm] -> [CASTerm]+foldTermsWith policy terms =+  let grouped = groupBy equalMonos (sortBy (comparing termMonoKey) terms)+  in concatMap combineTerms grouped+  where+    -- Use show-based key for consistent ordering+    termMonoKey (CASTerm _ m) = map (\(s, e) -> (show s, e)) (sortBy (comparing (show . fst)) m)+    termMono (CASTerm _ m) = sortBy (comparing (show . fst)) m+    equalMonos t1 t2 = termMono t1 == termMono t2+    normalizeCoeff c = case (policy, c) of+      (KeepNested, CASPoly ts) -> casNormalizePolyWith KeepNested ts+      _                        -> casNormalize c+    combineTerms [] = []+    combineTerms grp@((CASTerm _ m):_) =+      let mono = sortBy (comparing (show . fst)) m+          coeffSum = foldr casPlus' (CASInteger 0) [c | CASTerm c _ <- grp]+      in [CASTerm (normalizeCoeff coeffSum) mono]++-- | Sort terms in descending order (highest degree first)+-- Order: by total degree, then lexicographically by symbols+sortTermsDescending :: [CASTerm] -> [CASTerm]+sortTermsDescending = sortBy (flip (comparing termDegree) <> flip (comparing termSymbolsKey))+  where+    termDegree (CASTerm _ mono) = sum (map snd mono)+    -- Use show-based key for consistent lexicographic ordering+    termSymbolsKey (CASTerm _ mono) = map (\(s, e) -> (show s, e)) (sortBy (comparing (show . fst)) mono)++-- | Normalize a fraction+-- Steps:+-- 1. If denominator is 1, return numerator+-- 2. If numerator is 0, return 0+-- 3. Simplify using GCD+-- 4. Ensure positive denominator+casNormalizeFrac :: CASValue -> CASValue -> CASValue+casNormalizeFrac num denom =+  let num' = casNormalize num+      denom' = casNormalize denom+  in case (num', denom') of+       -- Zero numerator+       (n, _) | casIsZero n -> CASInteger 0+       -- Denominator is 1+       (n, d) | casIsOne d -> n+       -- Denominator is -1: negate numerator+       (n, CASInteger (-1)) -> casNegate n+       -- Integer / Integer: reduce by GCD and normalize sign+       (CASInteger n, CASInteger d) ->+         let g = gcd n d+             -- Normalize sign: ensure positive denominator+             sign = if d < 0 then -1 else 1+             n' = sign * (n `div` g)+             d' = abs (d `div` g)+         in if d' == 1+            then CASInteger n'+            else CASFrac (CASInteger n') (CASInteger d')+       -- Poly / Integer (constant denominator): per the type-promotion-tower+       -- design (type-cas.md §実行時の型昇格タワー), constant denominators are+       -- absorbed into each term's coefficient as a Frac. The result is+       -- level 4 (Poly with Frac coefficients) instead of level 5 (Frac of+       -- Poly), matching the canonical form for `Poly (Frac Integer) [..]`.+       (CASPoly ts1, CASInteger d) | d /= 0 ->+         let ts1' = map (\(CASTerm c m) ->+                           CASTerm (casNormalizeFrac c (CASInteger d)) m) ts1+         in casNormalizePoly ts1'+       -- Any / single-term-Poly with monomial denominator: per the+       -- type-promotion-tower design, monomial denominators are absorbed+       -- as negative exponents (Laurent polynomial form, level 3/4) rather+       -- than left as level 5 Frac. The numerator is normalized to Poly+       -- form (CASInteger n → [CASTerm n []], CASFactor sym → [CASTerm 1+       -- [(sym, 1)]]) and each term's exponents are decremented by the+       -- denominator's monomial.+       (numV, CASPoly [CASTerm denomCoef denomMono]) | not (null denomMono) ->+         let numTerms = case numV of+               CASPoly ts          -> ts+               CASInteger n        -> [CASTerm (CASInteger n) []]+               CASFactor sym       -> [CASTerm (CASInteger 1) [(sym, 1)]]+               _                   -> [CASTerm numV []]+             ts' = map (divTermByMonomial denomCoef denomMono) numTerms+         in casNormalizePoly ts'+       -- Poly / Poly (non-monomial denominator): try to reduce by monomial GCD,+       -- then by the univariate polynomial GCD; otherwise keep as level 5 Frac.+       -- After a proper polynomial-GCD reduction we re-enter casNormalizeFrac:+       -- the reduced pair is coprime (the second pass finds a constant GCD and+       -- stops), and a denominator that collapsed to a constant or a monomial+       -- is absorbed by the earlier branches.+       (CASPoly ts1, CASPoly ts2) ->+         let (ts1', ts2') = simplifyPolyDiv ts1 ts2+         in case (ts1', ts2') of+              (ts1'', [CASTerm (CASInteger 1) []]) -> casNormalizePoly ts1''+              _ -> case univariateGcdReduce ts1' ts2' of+                     Just (ts1'', ts2'') ->+                       casNormalizeFrac (casNormalizePoly ts1'') (casNormalizePoly ts2'')+                     Nothing -> case multivariateGcdReduce ts1' ts2' of+                       Just (ts1'', ts2'') ->+                         casNormalizeFrac (casNormalizePoly ts1'') (casNormalizePoly ts2'')+                       Nothing -> CASFrac (casNormalizePoly ts1') (casNormalizePoly ts2')+       -- a / (b / c) = (a * c) / b+       (n, CASFrac b c) -> casNormalizeFrac (casMult n c) b+       -- (a / b) / c = a / (b * c)+       (CASFrac a b, c) -> casNormalizeFrac a (casMult b c)+       -- Default: no simplification+       _ -> CASFrac num' denom'++--------------------------------------------------------------------------------+-- Type-driven reshape (Phase A of the reshape primitive design)+--------------------------------------------------------------------------------++-- | Reshape a CAS value to match the structure implied by the given Type.+--+-- This is the runtime side of the `reshape` primitive: type info comes from+-- a compile-time annotation embedded in the AST, and at evaluation time we+-- structurally rewrite the CASValue to fit that shape.+--+-- The implementation follows the type promotion tower (see type-cas-tower.md):+-- normalize first (which handles tower-level reductions), then recursively+-- adjust coefficients/numerators/denominators to match nested type arguments.+-- For values that cannot be reshaped to the target structure (e.g. a value+-- with free atoms reshaped to TInt), we leave the normalized form as-is —+-- per the "trust the annotation" principle.+casReshapeAs :: Type -> CASValue -> CASValue+casReshapeAs ty v = case ty of+  TInt           -> casNormalize v+  TMathValue     -> casNormalize v+  TFactor        -> casNormalize v+  TFrac inner    -> reshapeAsFrac inner v+  TPoly inner ss -> reshapeAsPoly inner ss v+  TTerm inner ss -> reshapeAsTerm inner ss v+  _              -> v  -- non-CAS types: pass through++-- | Frac inner: keep fraction form (or collapsed Integer when denom=1) and+-- recursively reshape numerator and denominator with the inner type.+reshapeAsFrac :: Type -> CASValue -> CASValue+reshapeAsFrac innerTy v = case casNormalize v of+  CASInteger n      -> CASInteger n+  CASFrac num denom -> casNormalizeFrac (casReshapeAs innerTy num)+                                        (casReshapeAs innerTy denom)+  cv                -> cv++-- | Poly inner [..]: structural reshape with atom-set separation.+--+-- Atom routing is driven by the whole inner tower — the chain of nested+-- Poly/Term coefficient types, descending through Frac — under the+-- restriction that a nested Poly tower contains AT MOST ONE open symbol+-- set `[..]` (checked statically at annotation and declaration sites,+-- Types.hasAmbiguousOpenTower):+--+--   * The inner tower is all closed (e.g. `Poly (Poly Integer [i]) [x]`,+--     or with an open OUTER set `Poly (Poly Integer [i]) [..]`): atoms+--     listed anywhere in the inner tower go into the coefficient (the deep+--     union, so towers of depth 3+ route correctly), the rest stay at this+--     level.+--   * The inner tower contains the open slot and this level's set is+--     closed (e.g. `Poly (Poly Integer [..]) [i]`): complement split —+--     atoms of this level's closed set stay here, everything else goes+--     into the coefficient.+--   * No routing information at all (base coefficient type such as+--     Integer, or both this level and the inner tower open — excluded by+--     the static check): no separation; just recurse on coefficients+--     (basic widening).+--+-- The inside atoms are folded into the coefficient (which is then+-- recursively reshaped to the inner type, repeating the same routing one+-- level deeper), the outside atoms form the new term's monomial.+-- Note (Phase gamma-prime): the entry `casNormalize v` flattens any nested+-- shape the input may carry, so reshape is a function of the VALUE only —+-- this is what makes the absorption law `casReshapeAs C . casReshapeAs B =+-- casReshapeAs C` hold (D5 coherence). The final grouping then uses the+-- keep-nested normalizer so the structure just built is not re-flattened.+reshapeAsPoly :: Type -> SymbolSet -> CASValue -> CASValue+reshapeAsPoly innerTy outerSS v = case casNormalize v of+  CASInteger n -> CASInteger n+  CASPoly ts   ->+    case atomSplit innerTy outerSS of+      Just split -> casNormalizePolyWith KeepNested (map (separateTerm innerTy split) ts)+      Nothing    -> casNormalizePolyWith KeepNested+                      [CASTerm (casReshapeAs innerTy c) m | CASTerm c m <- ts]+  cv           -> cv++-- | Term inner [...]: like Poly but expected to be a single-term form.+-- We do not enforce the single-term invariant here; the type checker is+-- responsible for that, and at runtime we just recurse.+reshapeAsTerm :: Type -> SymbolSet -> CASValue -> CASValue+reshapeAsTerm = reshapeAsPoly++-- | Which atoms of a term go into the coefficient at this Poly level.+data AtomSplit+  = InsideAtoms [TypeAtom]   -- ^ an atom goes inside iff it is listed+  | OutsideAtoms [TypeAtom]  -- ^ an atom goes inside iff it is NOT listed+                             --   (complement split for an open inner tower)++-- | Decide the atom split at one Poly level from the inner tower and this+-- level's own symbol set. Returns Nothing when there is no routing+-- information (basic widening).+atomSplit :: Type -> SymbolSet -> Maybe AtomSplit+atomSplit innerTy outerSS =+  let (innerClosed, innerOpens) = towerInfo innerTy+  in if innerOpens >= 1+       then case outerSS of+              SymbolSetClosed outerAtoms -> Just (OutsideAtoms outerAtoms)+              _                          -> Nothing+       else if null innerClosed+              then Nothing+              else Just (InsideAtoms innerClosed)++-- | Collect, over the whole inner tower (nested Poly/Term levels, descending+-- through Frac), the union of closed atom sets and the number of open+-- symbol sets.+towerInfo :: Type -> ([TypeAtom], Int)+towerInfo (TPoly inner ss) = combineSS ss (towerInfo inner)+towerInfo (TTerm inner ss) = combineSS ss (towerInfo inner)+towerInfo (TFrac inner)    = towerInfo inner+towerInfo _                = ([], 0)++combineSS :: SymbolSet -> ([TypeAtom], Int) -> ([TypeAtom], Int)+combineSS (SymbolSetClosed atoms) (as, n) = (atoms ++ as, n)+combineSS SymbolSetOpen           (as, n) = (as, n + 1)+combineSS (SymbolSetVar _)        (as, n) = (as, n)++-- | Split a single CASTerm given the atom split: the inside atoms are+-- multiplied into the coefficient and reshaped to `innTy`; the remaining+-- atoms become the new term's monomial.+separateTerm :: Type -> AtomSplit -> CASTerm -> CASTerm+separateTerm innTy split (CASTerm c mono) =+  let (innerMono, outerMono) =+        case split of+          InsideAtoms atoms  -> splitMonomialByAtoms atoms mono+          OutsideAtoms atoms -> let (out, inn) = splitMonomialByAtoms atoms mono+                                in (inn, out)+      coeffWithInner =+        if null innerMono+          then c+          else casMult c (CASPoly [CASTerm (CASInteger 1) innerMono])+      newCoeff = casReshapeAs innTy coeffWithInner+  in CASTerm newCoeff outerMono++-- | Partition a monomial: (atoms-in-inner-set, atoms-not-in-inner-set).+splitMonomialByAtoms :: [TypeAtom] -> Monomial -> (Monomial, Monomial)+splitMonomialByAtoms inAtoms = go [] []+  where+    go inAcc outAcc []                 = (reverse inAcc, reverse outAcc)+    go inAcc outAcc (e@(sym, _) : rest)+      | symbolInAtomSet sym inAtoms = go (e : inAcc) outAcc rest+      | otherwise                   = go inAcc (e : outAcc) rest++-- | Decide whether a SymbolExpr matches any TypeAtom in the inner set.+-- Matches `Symbol _ name _` against `TANameAtom name` (e.g. atom `i`).+-- Matches `Apply1..4 fn _` against `TAApplyAtom name _` by function name+-- (e.g. atom `sin x` for any single application of `sin`). The argument+-- structure inside the TypeAtom is not currently checked.+symbolInAtomSet :: SymbolExpr -> [TypeAtom] -> Bool+symbolInAtomSet sym = any (matches sym)+  where+    matches (Symbol _ name _) (TANameAtom n)    = name == n+    matches (Apply1 fn _)         (TAApplyAtom n _) = applyFnName fn == Just n+    matches (Apply2 fn _ _)       (TAApplyAtom n _) = applyFnName fn == Just n+    matches (Apply3 fn _ _ _)     (TAApplyAtom n _) = applyFnName fn == Just n+    matches (Apply4 fn _ _ _ _)   (TAApplyAtom n _) = applyFnName fn == Just n+    matches (FunctionData fn _)   (TAApplyAtom n _) = applyFnName fn == Just n+    matches _                 _                      = False++    applyFnName (CASFactor (Symbol _ n _))                                 = Just n+    applyFnName (CASPoly [CASTerm (CASInteger 1) [(Symbol _ n _, 1)]])     = Just n+    applyFnName _                                                          = Nothing++-- | Simplify polynomial division by extracting common monomial GCD+simplifyPolyDiv :: [CASTerm] -> [CASTerm] -> ([CASTerm], [CASTerm])+simplifyPolyDiv [] ts2 = ([], ts2)+simplifyPolyDiv ts1 [] = (ts1, [])+simplifyPolyDiv ts1 ts2 =+  let gcdTerm = casTermsGcd (ts1 ++ ts2)+  in (map (`divideTermBy` gcdTerm) ts1, map (`divideTermBy` gcdTerm) ts2)++-- | Divide a Term by a monomial denominator (single-term Poly's coef and mono).+-- Used for Laurent absorption: `(coef * mono) / (denomCoef * denomMono)` becomes+-- `(coef / denomCoef) * (mono - denomMono)` where exponents are subtracted.+divTermByMonomial :: CASValue -> Monomial -> CASTerm -> CASTerm+divTermByMonomial denomCoef denomMono (CASTerm c m) =+  CASTerm (casNormalizeFrac c denomCoef) (subtractMonomial m denomMono)++-- | Subtract one monomial from another (decrement exponents of shared symbols,+-- introduce negative exponents for symbols only in the divisor). Zero-exponent+-- entries are left in; `normalizeTermMonomial` will filter them out later.+subtractMonomial :: Monomial -> Monomial -> Monomial+subtractMonomial nums denoms = foldr subOne nums denoms+  where+    subOne (sym, denomExp) acc =+      case lookup sym acc of+        Just numExp ->+          (sym, numExp - denomExp) : filter ((/= sym) . fst) acc+        Nothing -> (sym, -denomExp) : acc++--------------------------------------------------------------------------------+-- GCD Operations+--------------------------------------------------------------------------------++-- | GCD of two CASValues (for coefficient reduction)+-- Initial implementation: only handles CASInteger, others return 1+casGcd :: CASValue -> CASValue -> CASValue+casGcd (CASInteger a) (CASInteger b) = CASInteger (gcd a b)+casGcd _ _ = CASInteger 1  -- Fallback: GCD = 1 for other coefficient types++-- | Compute the GCD of a list of terms (coefficient GCD + monomial GCD)+casTermsGcd :: [CASTerm] -> CASTerm+casTermsGcd [] = CASTerm (CASInteger 1) []+casTermsGcd [t] = t+casTermsGcd terms = foldl1 termGcd terms+  where+    termGcd (CASTerm c1 m1) (CASTerm c2 m2) =+      CASTerm (casGcd c1 c2) (monoGcd m1 m2)++-- | Reduce a Poly/Poly fraction by the univariate polynomial GCD over Q,+-- e.g. (x^2 - 1)/(x - 1) -> (x + 1)/1.+--+-- Stage-1 scope (design/type-cas-tower-implementation.md section 7): both+-- term lists must be univariate in the SAME single symbol with positive+-- exponents (the common monomial content has already been divided out by+-- 'simplifyPolyDiv', but per-side Laurent exponents may remain — those+-- bail out) and integer or integer-fraction coefficients. Anything else+-- returns Nothing and the fraction is left untouched.+--+-- The reduced pair is rescaled by a COMMON factor — integer coefficients,+-- joint content 1, positive leading denominator coefficient — so the+-- fraction's value is preserved exactly.+univariateGcdReduce :: [CASTerm] -> [CASTerm] -> Maybe ([CASTerm], [CASTerm])+univariateGcdReduce ts1 ts2+  | null ts1 || null ts2 = Nothing+  | otherwise = do+      sym <- singleCommonSymbol+      p1 <- toDense sym ts1+      p2 <- toDense sym ts2+      let g = polyGcdQ p1 p2+      if length g < 2  -- constant gcd: nothing to reduce+        then Nothing+        else do+          q1 <- exactDivQ p1 g+          q2 <- exactDivQ p2 g+          let l  = foldr (lcm . denominator) 1 (q1 ++ q2)+              i1 = map (numerator . (* (l % 1))) q1+              i2 = map (numerator . (* (l % 1))) q2+              c0 = foldr gcd 0 (i1 ++ i2)+              c  = if c0 == 0 then 1 else c0+              d  = case i2 of (x : _) | x < 0 -> negate c+                              _               -> c+          return (fromDense sym (map (`div` d) i1), fromDense sym (map (`div` d) i2))+  where+    -- Euclid on dense rationals is cheap for the degrees CAS code meets;+    -- the cutoff only guards against pathological inputs.+    maxGcdDegree :: Integer+    maxGcdDegree = 200++    singleCommonSymbol =+      case nub [ s | CASTerm _ m <- ts1 ++ ts2, (s, _) <- m ] of+        [s] -> Just s+        _   -> Nothing++    coefToRational (CASInteger n) = Just (n % 1)+    coefToRational (CASFrac (CASInteger a) (CASInteger b))+      | b /= 0 = Just (a % b)+    coefToRational _ = Nothing++    termExponent sym (CASTerm _ m) = case m of+      []                           -> Just 0+      [(s, e)] | s == sym && e > 0 -> Just e+      _                            -> Nothing++    -- Dense, highest-degree-first coefficient list over Q.+    toDense sym ts = do+      pairs <- mapM (\t@(CASTerm c _) ->+                       (,) <$> termExponent sym t <*> coefToRational c) ts+      let deg = maximum (map fst pairs)+      if deg > maxGcdDegree+        then Nothing+        else Just [ sum [ c | (e, c) <- pairs, e == d ] | d <- [deg, deg-1 .. 0] ]++    fromDense sym cs =+      [ CASTerm (CASInteger c) (if e == 0 then [] else [(sym, e)])+      | (e, c) <- zip [toInteger (length cs) - 1, toInteger (length cs) - 2 .. 0] cs+      , c /= 0 ]++    trim = dropWhile (== 0)++    -- Position-preserving long division (no mid-loop trimming: a zero that+    -- appears at the head after cancellation is a zero QUOTIENT coefficient,+    -- not a shorter polynomial). One quotient coefficient per step.+    polyDivModQ x0 y0 =+      let y = trim y0+          m = length y+          go r | length r < m = ([], r)+               | otherwise = case (r, y) of+                   (rh : rt, yh : yt) ->+                     let k  = rh / yh+                         r' = zipWith (-) rt+                                      (map (* k) (yt ++ replicate (length r - m) 0))+                         (qs, rest) = go r'+                     in (k : qs, rest)+                   _ -> error "polyDivModQ: division by the zero polynomial"+      in go (trim x0)++    polyGcdQ a b = go (trim a) (trim b)+      where+        go x [] = monic x+        go x y  = go y (trim (snd (polyDivModQ x y)))++    monic []        = []+    monic xs@(x0:_) = map (/ x0) xs++    exactDivQ x y =+      let (q, r) = polyDivModQ x y+      in if all (== 0) r then Just q else Nothing++-- | Reduce a Poly/Poly fraction by the multivariate polynomial GCD over the+-- rationals (subresultant PRS) — stage 2 of the fraction reduction+-- (design/cas-simplification.md G1).+--+-- Every atom (symbols, symbolic applications such as 'cos θ, quotes,+-- function symbols) is treated uniformly as a variable, so the reducer+-- covers Schwarzschild/T2/thurston-style cancellations with no extra+-- machinery. Fail-open: any input outside the supported shape (Laurent+-- exponents, non-rational coefficients, sizes beyond the guards) returns+-- Nothing and the fraction is left untouched.+--+-- Value preservation: both sides are scaled by ONE common denominator-+-- clearing factor, divided exactly by the same gcd, and finally rescaled by+-- a common integer content and sign, so the fraction's value never changes.+multivariateGcdReduce :: [CASTerm] -> [CASTerm] -> Maybe ([CASTerm], [CASTerm])+multivariateGcdReduce ts1 ts2+  | null ts1 || null ts2 = Nothing+  | otherwise = do+      rs1 <- mapM ratTerm ts1+      rs2 <- mapM ratTerm ts2+      -- Laurent exponents are out of scope (handled by the monomial layer).+      ensure (all (all ((> 0) . snd) . snd) (rs1 ++ rs2))+      let atoms = sortBy (comparing show)+                    (nub [ s | (_, m) <- rs1 ++ rs2, (s, _) <- m ])+      -- The univariate reducer owns the single-symbol case.+      ensure (length atoms >= 2 && length atoms <= mpMaxAtoms)+      let nAtoms = length atoms+          scale  = foldr (lcm . denominator . fst) 1 (rs1 ++ rs2)+          zeroV  = replicate nAtoms 0+          oneMP  = [(1, zeroV)]++          toVec m = [ sum [ e | (s, e) <- m', s == a ] | a <- atoms ]+            where m' = foldMonomialSymbols m+          conv rs = mpNorm [ (numerator (c * (scale % 1)), toVec m) | (c, m) <- rs ]+          p = conv rs1+          q = conv rs2++          -- Descending graded-lexicographic order over the fixed atom list;+          -- a proper monomial order, so leading-term exact division works.+          mpGrlex a b = compare (sum a, a) (sum b, b)+          mpNorm ts =+            [ (c, v)+            | grp@((_, v) : _) <- groupBy ((==) `on` snd)+                                    (sortBy (flip mpGrlex `on` snd) ts)+            , let c = sum (map fst grp)+            , c /= 0 ]++          mpNeg   = map (\(c, v) -> (negate c, v))+          mpAdd a b = mpNorm (a ++ b)+          mpSub a b = mpAdd a (mpNeg b)+          mpMul a b = mpNorm [ (c1 * c2, zipWith (+) v1 v2)+                             | (c1, v1) <- a, (c2, v2) <- b ]+          mpMulTerm (c, v) b = mpNorm [ (c * c2, zipWith (+) v v2) | (c2, v2) <- b ]+          mpPow b n = foldr mpMul oneMP (replicate (fromInteger n) b)++          mpMaxTotalDeg f = maximum (0 : [ sum v | (_, v) <- f ])+          mpDegIn i f     = maximum (0 : [ v !! i | (_, v) <- f ])+          mpPresent f     = [ i | i <- [0 .. nAtoms - 1]+                                , any (\(_, v) -> v !! i > 0) f ]+          mpIntContent f  = foldr (gcd . fst) 0 f++          -- Positive normalization: strip the integer content, make the+          -- leading (grlex) coefficient positive.+          mpPosNorm [] = []+          mpPosNorm f  =+            let c0 = mpIntContent f+                s  = case f of ((c, _) : _) | c < 0 -> -1+                               _                    -> 1+                d  = s * c0+            in map (\(c, v) -> (c `div` d, v)) f++          -- Leading-term exact division; Nothing when not exact.+          mpDivExact _ [] = Nothing+          mpDivExact a0 b@((bc, bv) : _) = go a0 []+            where+              go [] acc = Just (mpNorm acc)+              go a@((ac, av) : _) acc+                | all (>= 0) dv && ac `mod` bc == 0 =+                    let qt = (ac `div` bc, dv)+                    in go (mpSub a (mpMulTerm qt b)) (qt : acc)+                | otherwise = Nothing+                where dv = zipWith (-) av bv++          zeroAtI i v = take i v ++ [0] ++ drop (i + 1) v++          -- Univariate view in atom i: (degree, coefficient poly without i),+          -- degrees descending.+          mpUniView i f =+            [ (v0 !! i, mpNorm [ (c, zeroAtI i v) | (c, v) <- grp ])+            | grp@((_, v0) : _) <- groupBy ((==) `on` ((!! i) . snd))+                                     (sortBy (flip compare `on` ((!! i) . snd)) f) ]++          mpCoefAt i d f = mpNorm [ (c, zeroAtI i v) | (c, v) <- f, v !! i == d ]+          mpLeadCoef i f = mpCoefAt i (mpDegIn i f) f+          mpShift i k    = map (\(c, v) ->+                                  (c, take i v ++ [v !! i + k] ++ drop (i + 1) v))++          -- Content and primitive part with respect to atom i.+          mpContentI i f = goC (map snd (mpUniView i f))+            where+              goC []       = Just oneMP+              goC [c0]     = Just (mpPosNorm c0)+              goC (c0 : cs) = do+                rest <- goC cs+                if rest == oneMP then Just oneMP else mpGcdM (mpPosNorm c0) rest++          -- Knuth's division-free pseudo-remainder of f1 by f2 in atom i:+          -- the remainder of lc(f2)^(delta+1) * f1 divided by f2.+          mpPrem i f1 f2 =+            let dq  = mpDegIn i f2+                lcq = mpLeadCoef i f2+                step r k =+                  let ck = mpCoefAt i (dq + k) r+                      r' = mpSub (mpMul lcq r) (mpMul (mpShift i k ck) f2)+                  in r'+                go r k | length r > mpPrsTermCap = Nothing+                       | k < 0     = Just r+                       | otherwise = go (step r k) (k - 1)+            in go f1 (mpDegIn i f1 - dq)++          -- Subresultant PRS on primitive parts; returns the gcd of the+          -- primitive parts (a unit when they are coprime in atom i).+          mpPrsGcd i f1 f2+            | mpDegIn i f1 < mpDegIn i f2 = mpPrsGcd i f2 f1+            | mpDegIn i f2 == 0 = Just oneMP+            | otherwise = loop f1 f2 oneMP oneMP+            where+              loop a b g h = do+                ensure (length a <= mpPrsTermCap && length b <= mpPrsTermCap)+                let delta = mpDegIn i a - mpDegIn i b+                r <- mpPrem i a b+                if null r+                  then do c <- mpContentI i b+                          mpDivExact b c+                  else if mpDegIn i r == 0+                    then Just oneMP+                    else do+                      b' <- mpDivExact r (mpMul g (mpPow h delta))+                      let g' = mpLeadCoef i b+                      h' <- case delta of+                              0 -> Just h+                              1 -> Just g'+                              _ -> mpDivExact (mpPow g' delta)+                                              (mpPow h (delta - 1))+                      loop b b' g' h'++          -- Multivariate gcd, recursing on the set of present atoms.+          mpGcdM a b+            | null a = Just (mpPosNorm b)+            | null b = Just (mpPosNorm a)+            | otherwise =+                case mpPresent a ++ mpPresent b of+                  [] -> Just [(gcd (mpIntContent a) (mpIntContent b), zeroV)]+                  idxs -> do+                    let i = pickVar (nub idxs)+                    ca <- mpContentI i a+                    pa <- mpDivExact a ca+                    cb <- mpContentI i b+                    pb <- mpDivExact b cb+                    c  <- mpGcdM ca cb+                    g  <- mpPrsGcd i pa pb+                    Just (mpPosNorm (mpMul c g))+            where+              pickVar is = snd (minimum+                [ (mpDegIn i a + mpDegIn i b, i) | i <- is ])++          -- Deterministic coprimality prefilter: evaluate both sides at a+          -- fixed prime point; a common divisor g must satisfy g(pt) | gcd+          -- of the evaluations, so gcd 1 certifies that any common divisor+          -- is a unit at that point (heuristic skip; fail-open, and+          -- deterministic because the points are fixed).+          mpEval pt f = sum [ c * product (zipWith (^) pt v) | (c, v) <- f ]+          evalCoprime =+            any certify [ [3,5,7,11,13,17,19,23], [29,31,37,41,43,47,53,59] ]+            where+              certify pt =+                let a = mpEval (take nAtoms pt) p+                    b = mpEval (take nAtoms pt) q+                in a /= 0 && b /= 0 && gcd a b == 1++      ensure (length p <= mpMaxTerms && length q <= mpMaxTerms)+      ensure (mpMaxTotalDeg p <= mpMaxDegree && mpMaxTotalDeg q <= mpMaxDegree)+      ensure (not (null (mpPresent p `intersect` mpPresent q)))+      ensure (not evalCoprime)+      g <- mpGcdM p q+      ensure (mpMaxTotalDeg g > 0)+      pR <- mpDivExact p g+      qR <- mpDivExact q g+      -- Common rescale of the reduced pair (value-preserving): joint integer+      -- content out, denominator's leading coefficient positive.+      let cJ = gcd (mpIntContent pR) (mpIntContent qR)+          sg = case qR of ((c, _) : _) | c < 0 -> -1+                          _                    -> 1+          d  = sg * (if cJ == 0 then 1 else cJ)+          toTerms f = [ CASTerm (CASInteger (c `div` d))+                                [ (a, e) | (a, e) <- zip atoms v, e /= 0 ]+                      | (c, v) <- f ]+      return (toTerms pR, toTerms qR)+  where+    ensure b = if b then Just () else Nothing++    ratTerm (CASTerm c m) = (\r -> (r, m)) <$> ratCoef c+    ratCoef (CASInteger n) = Just (n % 1)+    ratCoef (CASFrac (CASInteger a) (CASInteger b)) | b /= 0 = Just (a % b)+    ratCoef _ = Nothing++    mpMaxAtoms  = 8+    mpMaxTerms  = 200+    mpMaxDegree = 60 :: Integer+    mpPrsTermCap = 2000++-- | GCD of two monomials: take minimum exponent for each shared symbol+monoGcd :: Monomial -> Monomial -> Monomial+monoGcd [] _ = []+monoGcd ((sym, expo):rest) mono =+  case lookup sym mono of+    Just exp' -> (sym, min expo exp') : monoGcd rest mono+    Nothing   -> monoGcd rest mono++-- | Divide a term by another term (for GCD reduction)+divideTermBy :: CASTerm -> CASTerm -> CASTerm+divideTermBy (CASTerm coeff1 mono1) (CASTerm coeff2 mono2) =+  CASTerm (divCoeff coeff1 coeff2) (divMono mono1 mono2)+  where+    divCoeff (CASInteger a) (CASInteger b) = CASInteger (a `div` b)+    divCoeff a _ = a  -- Fallback: no division for other types++    divMono m [] = m+    divMono m ((sym, expo):rest) =+      let m' = map (\(s, e) -> if s == sym then (s, e - expo) else (s, e)) m+      in divMono m' rest++--------------------------------------------------------------------------------+-- Pattern Synonyms for CASValue+--------------------------------------------------------------------------------++-- | Pattern for zero value+pattern CASZero :: CASValue+pattern CASZero = CASInteger 0++-- | Pattern for a single symbol: sym → 1 * sym^1+pattern CASSingleSymbol :: SymbolExpr -> CASValue+pattern CASSingleSymbol sym = CASPoly [CASTerm (CASInteger 1) [(sym, 1)]]++-- | Pattern for a single term: coeff * mono+pattern CASSingleTerm :: Integer -> Monomial -> CASValue+pattern CASSingleTerm coeff mono = CASPoly [CASTerm (CASInteger coeff) mono]++--------------------------------------------------------------------------------+-- Pattern Matching (control-egison matchers)+--------------------------------------------------------------------------------++-- | Matcher for CASValue+data CASM = CASM+instance Matcher CASM CASValue++-- | Matcher for CASTerm+data CASTermM = CASTermM+instance Matcher CASTermM CASTerm++-- | Matcher for SymbolExpr (CAS version)+data CASSymbolM = CASSymbolM+instance Matcher CASSymbolM SymbolExpr++-- | Match a term and extract its coefficient and monomial+casTerm' :: Pattern (PP CASValue, PP Monomial) CASTermM CASTerm (CASValue, Monomial)+casTerm' _ _ (CASTerm coeff mono) = pure (coeff, mono)+-- | Matcher decomposition for casTerm' pattern+casTerm'M :: CASTermM -> CASTerm -> (CASM, Multiset (CASSymbolM, Eql))+casTerm'M CASTermM _ = (CASM, Multiset (CASSymbolM, Eql))+casTermM :: CASTermM -> CASTerm -> (CASM, Multiset (CASSymbolM, Eql))+casTermM CASTermM _ = (CASM, Multiset (CASSymbolM, Eql))++-- | Match a symbol and extract its name+casSymbol :: Pattern (PP String) CASSymbolM SymbolExpr String+casSymbol _ _ (Symbol _ name []) = pure name+casSymbol _ _ _                  = mzero+casSymbolM :: CASSymbolM -> p -> Eql+casSymbolM CASSymbolM _ = Eql++-- | Match a function and extract its name and arguments+casFunc :: Pattern (PP CASValue, PP [CASValue])+                CASSymbolM SymbolExpr (CASValue, [CASValue])+casFunc _ _ (FunctionData name args) = pure (name, args)+casFunc _ _ _                        = mzero+casFuncM :: CASSymbolM -> SymbolExpr -> (CASM, List CASM)+casFuncM CASSymbolM _ = (CASM, List CASM)++-- | Match Apply1 and extract function name, WHNF, and argument+casApply1 :: Pattern (PP String, PP WHNFData, PP CASValue) CASSymbolM SymbolExpr (String, WHNFData, CASValue)+casApply1 _ _ (Apply1 (CASSingleSymbol (QuoteFunction fnWhnf)) a1) =+  case prettyFunctionName fnWhnf of+    Just fn -> pure (fn, fnWhnf, a1)+    Nothing -> mzero+casApply1 _ _ _ = mzero+casApply1M :: CASSymbolM -> p -> (Eql, Something, CASM)+casApply1M CASSymbolM _ = (Eql, Something, CASM)++-- | Match Apply2 and extract function name, WHNF, and arguments+casApply2 :: Pattern (PP String, PP WHNFData, PP CASValue, PP CASValue) CASSymbolM SymbolExpr (String, WHNFData, CASValue, CASValue)+casApply2 _ _ (Apply2 (CASSingleSymbol (QuoteFunction fnWhnf)) a1 a2) =+  case prettyFunctionName fnWhnf of+    Just fn -> pure (fn, fnWhnf, a1, a2)+    Nothing -> mzero+casApply2 _ _ _ = mzero+casApply2M :: CASSymbolM -> p -> (Eql, Something, CASM, CASM)+casApply2M CASSymbolM _ = (Eql, Something, CASM, CASM)++-- | Match Apply3 and extract function name, WHNF, and arguments+casApply3 :: Pattern (PP String, PP WHNFData, PP CASValue, PP CASValue, PP CASValue) CASSymbolM SymbolExpr (String, WHNFData, CASValue, CASValue, CASValue)+casApply3 _ _ (Apply3 (CASSingleSymbol (QuoteFunction fnWhnf)) a1 a2 a3) =+  case prettyFunctionName fnWhnf of+    Just fn -> pure (fn, fnWhnf, a1, a2, a3)+    Nothing -> mzero+casApply3 _ _ _ = mzero+casApply3M :: CASSymbolM -> p -> (Eql, Something, CASM, CASM, CASM)+casApply3M CASSymbolM _ = (Eql, Something, CASM, CASM, CASM)++-- | Match Apply4 and extract function name, WHNF, and arguments+casApply4 :: Pattern (PP String, PP WHNFData, PP CASValue, PP CASValue, PP CASValue, PP CASValue) CASSymbolM SymbolExpr (String, WHNFData, CASValue, CASValue, CASValue, CASValue)+casApply4 _ _ (Apply4 (CASSingleSymbol (QuoteFunction fnWhnf)) a1 a2 a3 a4) =+  case prettyFunctionName fnWhnf of+    Just fn -> pure (fn, fnWhnf, a1, a2, a3, a4)+    Nothing -> mzero+casApply4 _ _ _ = mzero+casApply4M :: CASSymbolM -> p -> (Eql, Something, CASM, CASM, CASM, CASM)+casApply4M CASSymbolM _ = (Eql, Something, CASM, CASM, CASM, CASM)++-- | Match Quote and extract the inner CASValue+casQuote :: Pattern (PP CASValue) CASSymbolM SymbolExpr CASValue+casQuote _ _ (Quote m) = pure m+casQuote _ _ _         = mzero++-- | Match Quote and extract the negated inner CASValue+casNegQuote :: Pattern (PP CASValue) CASSymbolM SymbolExpr CASValue+casNegQuote _ _ (Quote m) = pure (casNegate m)+casNegQuote _ _ _         = mzero+casNegQuoteM :: CASSymbolM -> p -> CASM+casNegQuoteM CASSymbolM _ = CASM++-- | Match QuoteFunction and extract function name and WHNF+casQuoteFunction :: Pattern (PP String, PP WHNFData) CASSymbolM SymbolExpr (String, WHNFData)+casQuoteFunction _ _ (QuoteFunction whnf) = case prettyFunctionName whnf of+  Just name -> pure (name, whnf)+  Nothing   -> mzero+casQuoteFunction _ _ _ = mzero+casQuoteFunctionM :: CASSymbolM -> p -> Eql+casQuoteFunctionM CASSymbolM _ = Eql++-- | Match equal monomial (checks if two monomials are equal, handling sign)+casEqualMonomial :: Pattern (PP Integer, PP Monomial) (Multiset (CASSymbolM, Eql)) Monomial (Integer, Monomial)+casEqualMonomial (_, VP xs) _ ys = case casIsEqualMonomial xs ys of+                                  Just sgn -> pure (sgn, xs)+                                  Nothing  -> mzero+casEqualMonomial _ _ _ = mzero+casEqualMonomialM :: Multiset (CASSymbolM, Eql) -> p -> (Eql, Multiset (CASSymbolM, Eql))+casEqualMonomialM (Multiset (CASSymbolM, Eql)) _ = (Eql, Multiset (CASSymbolM, Eql))++-- | Check if two monomials are equal, returning sign if so+casIsEqualMonomial :: Monomial -> Monomial -> Maybe Integer+casIsEqualMonomial xs ys =+  match dfs (xs, ys) (Multiset (CASSymbolM, Eql), Multiset (CASSymbolM, Eql))+    [ [mc| ((casQuote $s, $n) : $xss, (casNegQuote #s, #n) : $yss) ->+             case casIsEqualMonomial xss yss of+               Nothing -> Nothing+               Just sgn -> return (if even n then sgn else - sgn) |]+    , [mc| (($x, $n) : $xss, (#x, #n) : $yss) -> casIsEqualMonomial xss yss |]+    , [mc| ([], []) -> return 1 |]+    , [mc| _ -> Nothing |]+    ]++-- | Match zero CASValue+casZero :: Pattern () CASM CASValue ()+casZero _ _ CASZero    = pure ()+casZero _ _ (CASPoly []) = pure ()  -- Empty polynomial is also zero+casZero _ _ _          = mzero+casZeroM :: CASM -> p -> ()+casZeroM CASM _ = ()++-- | Match a single term in CASValue and extract coefficient, denominator coefficient, and monomial+casSingleTerm :: Pattern (PP Integer, PP Integer, PP Monomial) CASM CASValue (Integer, Integer, Monomial)+casSingleTerm _ _ (CASFrac (CASPoly [CASTerm (CASInteger c) mono]) (CASPoly [CASTerm (CASInteger c2) []])) = pure (c, c2, mono)+casSingleTerm _ _ (CASFrac (CASSingleTerm c mono) (CASInteger c2)) = pure (c, c2, mono)+casSingleTerm _ _ (CASPoly [CASTerm (CASInteger c) mono]) = pure (c, 1, mono)+casSingleTerm _ _ (CASInteger n) = pure (n, 1, [])  -- Integer is a single term with empty monomial+casSingleTerm _ _ _ = mzero+casSingleTermM :: CASM -> p -> (Eql, Eql, Multiset (CASSymbolM, Eql))+casSingleTermM CASM _ = (Eql, Eql, Multiset (CASSymbolM, Eql))++-- | ValuePattern instance for CASM+instance ValuePattern CASM CASValue where+  value e () CASM v = if e == v then pure () else mzero++-- | ValuePattern instance for CASSymbolM+instance ValuePattern CASSymbolM SymbolExpr where+  value e () CASSymbolM v = if e == v then pure () else mzero

@@ -1,360 +0,0 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms       #-}-{-# LANGUAGE QuasiQuotes           #-}--{- |-Module      : Language.Egison.Math.Expr-Licence     : MIT--This module defines the internal representation of mathematic objects such as-polynominals, and some useful patterns.--}--module Language.Egison.Math.Expr-    ( ScalarData (..)-    , PolyExpr (..)-    , TermExpr (..)-    , Monomial-    , SymbolExpr (..)-    , Printable (..)-    , pattern ZeroExpr-    , pattern SingleSymbol-    , pattern SingleTerm-    , ScalarM (..)-    , TermM (..)-    , SymbolM (..)-    , term-    , termM-    , symbol-    , symbolM-    , func-    , funcM-    , apply1-    , apply1M-    , apply2-    , apply2M-    , apply3-    , apply3M-    , apply4-    , apply4M-    , quote-    , negQuote-    , negQuoteM-    , quoteFunction-    , quoteFunctionM-    , equalMonomial-    , equalMonomialM-    , zero-    , zeroM-    , singleTerm-    , singleTermM-    , mathScalarMult-    , mathNegate-    , makeApplyExpr-    ) where--import           Data.List             (intercalate)-import           Prelude               hiding (foldr, mappend, mconcat)--import           Control.Egison-import           Control.Monad         (MonadPlus (..))--import           Language.Egison.IExpr (Index (..))-import {-# SOURCE #-} Language.Egison.Data (WHNFData, prettyFunctionName)------- Data------data ScalarData-  = Div PolyExpr PolyExpr- deriving Eq--newtype PolyExpr-  = Plus [TermExpr]--data TermExpr-  = Term Integer Monomial---- We choose the definition 'monomials' without its coefficients.--- ex. 2 x^2 y^3 is *not* a monomial. x^2 t^3 is a monomial.-type Monomial = [(SymbolExpr, Integer)]--data SymbolExpr-  = Symbol Id String [Index ScalarData]-  | Apply1 ScalarData ScalarData-  | Apply2 ScalarData ScalarData ScalarData-  | Apply3 ScalarData ScalarData ScalarData ScalarData-  | Apply4 ScalarData ScalarData ScalarData ScalarData ScalarData-  | Quote ScalarData                     -- For backtick quote: `expr-  | QuoteFunction WHNFData              -- For single quote on functions: 'func-  | FunctionData ScalarData [ScalarData] -- fnname args---- Manual Eq instance (QuoteFunction comparison always returns False)-instance Eq SymbolExpr where-  Symbol id1 s1 js1 == Symbol id2 s2 js2 = id1 == id2 && s1 == s2 && js1 == js2-  Apply1 f1 a1 == Apply1 f2 a2 = f1 == f2 && a1 == a2-  Apply2 f1 a1 b1 == Apply2 f2 a2 b2 = f1 == f2 && a1 == a2 && b1 == b2-  Apply3 f1 a1 b1 c1 == Apply3 f2 a2 b2 c2 = f1 == f2 && a1 == a2 && b1 == b2 && c1 == c2-  Apply4 f1 a1 b1 c1 d1 == Apply4 f2 a2 b2 c2 d2 = f1 == f2 && a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2-  Quote m1 == Quote m2 = m1 == m2-  QuoteFunction whnf1 == QuoteFunction whnf2 = -    case (prettyFunctionName whnf1, prettyFunctionName whnf2) of-      (Just n1, Just n2) -> n1 == n2-      _ -> False  -- Anonymous functions are never equal-  FunctionData n1 k1 == FunctionData n2 k2 = n1 == n2 && k1 == k2-  _ == _ = False---- Helper function to create Apply constructors based on argument count-makeApplyExpr :: ScalarData -> [ScalarData] -> SymbolExpr-makeApplyExpr fn [a1] = Apply1 fn a1-makeApplyExpr fn [a1, a2] = Apply2 fn a1 a2-makeApplyExpr fn [a1, a2, a3] = Apply3 fn a1 a2 a3-makeApplyExpr fn [a1, a2, a3, a4] = Apply4 fn a1 a2 a3 a4-makeApplyExpr _ _ = error "makeApplyExpr: unsupported number of arguments (must be 1-4)"--type Id = String---- Matchers--data ScalarM = ScalarM-instance Matcher ScalarM ScalarData--data TermM = TermM-instance Matcher TermM TermExpr--data SymbolM = SymbolM-instance Matcher SymbolM SymbolExpr--term :: Pattern (PP Integer, PP Monomial) TermM TermExpr (Integer, Monomial)-term _ _ (Term a mono) = pure (a, mono)-termM :: TermM -> TermExpr -> (Eql, Multiset (SymbolM, Eql))-termM TermM _ = (Eql, Multiset (SymbolM, Eql))--symbol :: Pattern (PP String) SymbolM SymbolExpr String-symbol _ _ (Symbol _ name []) = pure name-symbol _ _ _                  = mzero-symbolM :: SymbolM -> p -> Eql-symbolM SymbolM _ = Eql--func :: Pattern (PP ScalarData, PP [ScalarData])-                SymbolM SymbolExpr (ScalarData, [ScalarData])-func _ _ (FunctionData name args) = pure (name, args)-func _ _ _                        = mzero-funcM :: SymbolM -> SymbolExpr -> (ScalarM, List ScalarM)-funcM SymbolM _ = (ScalarM, List ScalarM)--apply1 :: Pattern (PP String, PP WHNFData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData)-apply1 _ _ (Apply1 (SingleSymbol (QuoteFunction fnWhnf)) a1) =-  case prettyFunctionName fnWhnf of-    Just fn -> pure (fn, fnWhnf, a1)-    Nothing -> mzero-apply1 _ _ _ = mzero-apply1M :: SymbolM -> p -> (Eql, Something, ScalarM)-apply1M SymbolM _ = (Eql, Something, ScalarM)--apply2 :: Pattern (PP String, PP WHNFData, PP ScalarData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData, ScalarData)-apply2 _ _ (Apply2 (SingleSymbol (QuoteFunction fnWhnf)) a1 a2) =-  case prettyFunctionName fnWhnf of-    Just fn -> pure (fn, fnWhnf, a1, a2)-    Nothing -> mzero-apply2 _ _ _ = mzero-apply2M :: SymbolM -> p -> (Eql, Something, ScalarM, ScalarM)-apply2M SymbolM _ = (Eql, Something, ScalarM, ScalarM)--apply3 :: Pattern (PP String, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData, ScalarData, ScalarData)-apply3 _ _ (Apply3 (SingleSymbol (QuoteFunction fnWhnf)) a1 a2 a3) =-  case prettyFunctionName fnWhnf of-    Just fn -> pure (fn, fnWhnf, a1, a2, a3)-    Nothing -> mzero-apply3 _ _ _ = mzero-apply3M :: SymbolM -> p -> (Eql, Something, ScalarM, ScalarM, ScalarM)-apply3M SymbolM _ = (Eql, Something, ScalarM, ScalarM, ScalarM)--apply4 :: Pattern (PP String, PP WHNFData, PP ScalarData, PP ScalarData, PP ScalarData, PP ScalarData) SymbolM SymbolExpr (String, WHNFData, ScalarData, ScalarData, ScalarData, ScalarData)-apply4 _ _ (Apply4 (SingleSymbol (QuoteFunction fnWhnf)) a1 a2 a3 a4) =-  case prettyFunctionName fnWhnf of-    Just fn -> pure (fn, fnWhnf, a1, a2, a3, a4)-    Nothing -> mzero-apply4 _ _ _ = mzero-apply4M :: SymbolM -> p -> (Eql, Something, ScalarM, ScalarM, ScalarM, ScalarM)-apply4M SymbolM _ = (Eql, Something, ScalarM, ScalarM, ScalarM, ScalarM)--quote :: Pattern (PP ScalarData) SymbolM SymbolExpr ScalarData-quote _ _ (Quote m) = pure m-quote _ _ _         = mzero--negQuote :: Pattern (PP ScalarData) SymbolM SymbolExpr ScalarData-negQuote _ _ (Quote m) = pure (mathNegate m)-negQuote _ _ _         = mzero-negQuoteM :: SymbolM -> p -> ScalarM-negQuoteM SymbolM _ = ScalarM--quoteFunction :: Pattern (PP String, PP WHNFData) SymbolM SymbolExpr (String, WHNFData)-quoteFunction _ _ (QuoteFunction whnf) = case prettyFunctionName whnf of-  Just name -> pure (name, whnf)-  Nothing   -> mzero-quoteFunction _ _ _ = mzero-quoteFunctionM :: SymbolM -> p -> Eql-quoteFunctionM SymbolM _ = Eql--equalMonomial :: Pattern (PP Integer, PP Monomial) (Multiset (SymbolM, Eql)) Monomial (Integer, Monomial)-equalMonomial (_, VP xs) _ ys = case isEqualMonomial xs ys of-                                  Just sgn -> pure (sgn, xs)-                                  Nothing  -> mzero-equalMonomial _ _ _ = mzero-equalMonomialM :: Multiset (SymbolM, Eql) -> p -> (Eql, Multiset (SymbolM, Eql))-equalMonomialM (Multiset (SymbolM, Eql)) _ = (Eql, Multiset (SymbolM, Eql))--zero :: Pattern () ScalarM ScalarData ()-zero _ _ (Div (Plus []) _) = pure ()-zero _ _ _                 = mzero-zeroM :: ScalarM -> p -> ()-zeroM ScalarM _ = ()--singleTerm :: Pattern (PP Integer, PP Integer, PP Monomial) ScalarM ScalarData (Integer, Integer, Monomial)-singleTerm _ _ (Div (Plus [Term c mono]) (Plus [Term c2 []])) = pure (c, c2, mono)-singleTerm _ _ _                                              = mzero-singleTermM :: ScalarM -> p -> (Eql, Eql, Multiset (SymbolM, Eql))-singleTermM ScalarM _ = (Eql, Eql, Multiset (SymbolM, Eql))---instance ValuePattern ScalarM ScalarData where-  value e () ScalarM v = if e == v then pure () else mzero--instance ValuePattern SymbolM SymbolExpr where-  value e () SymbolM v = if e == v then pure () else mzero---pattern ZeroExpr :: ScalarData-pattern ZeroExpr = (Div (Plus []) (Plus [Term 1 []]))--pattern SingleSymbol :: SymbolExpr -> ScalarData-pattern SingleSymbol sym = Div (Plus [Term 1 [(sym, 1)]]) (Plus [Term 1 []])---- Product of a coefficient and a monomial-pattern SingleTerm :: Integer -> Monomial -> ScalarData-pattern SingleTerm coeff mono = Div (Plus [Term coeff mono]) (Plus [Term 1 []])--instance Eq PolyExpr where-  Plus xs == Plus ys =-    match dfs ys (Multiset Eql)-      [ [mc| #xs -> True |]-      , [mc| _   -> False |] ]--instance Eq TermExpr where-  Term a xs == Term b ys-    | a == b    = isEqualMonomial xs ys == Just 1-    | a == -b   = isEqualMonomial xs ys == Just (-1)-    | otherwise = False--isEqualMonomial :: Monomial -> Monomial -> Maybe Integer-isEqualMonomial xs ys =-  match dfs (xs, ys) (Multiset (SymbolM, Eql), Multiset (SymbolM, Eql))-    [ [mc| ((quote $s, $n) : $xss, (negQuote #s, #n) : $yss) ->-             case isEqualMonomial xss yss of-               Nothing -> Nothing-               Just sgn -> return (if even n then sgn else - sgn) |]-    , [mc| (($x, $n) : $xss, (#x, #n) : $yss) -> isEqualMonomial xss yss |]-    , [mc| ([], []) -> return 1 |]-    , [mc| _ -> Nothing |]-    ]-------  Arithmetic operations-----mathScalarMult :: Integer -> ScalarData -> ScalarData-mathScalarMult c (Div m n) = Div (f c m) n-  where-    f c (Plus ts) = Plus (map (\(Term a xs) -> Term (c * a) xs) ts)--mathNegate :: ScalarData -> ScalarData-mathNegate = mathScalarMult (-1)------- Pretty printing-----class Printable a where-  isAtom :: a -> Bool-  pretty :: a -> String--pretty' :: Printable a => a -> String-pretty' e | isAtom e = pretty e-pretty' e            = "(" ++ pretty e ++ ")"--instance Printable ScalarData where-  isAtom (Div p (Plus [Term 1 []])) = isAtom p-  isAtom _                          = False--  pretty (Div p1 (Plus [Term 1 []])) = pretty p1-  pretty (Div p1 p2)                 = pretty'' p1 ++ " / " ++ pretty' p2-    where-      pretty'' :: PolyExpr -> String-      pretty'' p@(Plus [_]) = pretty p-      pretty'' p            = "(" ++ pretty p ++ ")"--instance Printable PolyExpr where-  isAtom (Plus [])           = True-  isAtom (Plus [Term _ []])  = True-  isAtom (Plus [Term 1 [_]]) = True-  isAtom _                   = False--  pretty (Plus []) = "0"-  pretty (Plus (t:ts)) = pretty t ++ concatMap withSign ts-    where-      withSign (Term a xs) | a < 0 = " - " ++ pretty (Term (- a) xs)-      withSign t                   = " + " ++ pretty t--instance Printable SymbolExpr where-  isAtom Symbol{}        = True-  isAtom Quote{}         = True-  isAtom QuoteFunction{} = True-  isAtom _               = False--  pretty (Symbol _ (':':':':':':_) []) = "#"-  pretty (Symbol _ s [])               = s-  pretty (Symbol _ s js)               = s ++ concatMap show js-  pretty (Apply1 fn a1)                = unwords (map pretty' [fn, a1])-  pretty (Apply2 fn a1 a2)             = unwords (map pretty' [fn, a1, a2])-  pretty (Apply3 fn a1 a2 a3)          = unwords (map pretty' [fn, a1, a2, a3])-  pretty (Apply4 fn a1 a2 a3 a4)       = unwords (map pretty' [fn, a1, a2, a3, a4])-  pretty (Quote mExprs)                = "`" ++ pretty' mExprs-  pretty (QuoteFunction whnf)          = "'" ++ maybe "<function>" id (prettyFunctionName whnf)-  pretty (FunctionData name args)      = unwords (pretty name : map pretty' args)--instance Printable TermExpr where-  isAtom (Term _ [])  = True-  isAtom (Term 1 [_]) = True-  isAtom _            = False--  pretty (Term a [])    = show a-  pretty (Term 1 xs)    = intercalate " * " (map prettyPoweredSymbol xs)-  pretty (Term (-1) xs) = "- " ++ intercalate " * " (map prettyPoweredSymbol xs)-  pretty (Term a xs)    = intercalate " * " (show a : map prettyPoweredSymbol xs)--prettyPoweredSymbol :: (SymbolExpr, Integer) -> String-prettyPoweredSymbol (x, 1) = show x-prettyPoweredSymbol (x, n) = pretty' x ++ "^" ++ show n--instance Show ScalarData where-  show = pretty--instance Show PolyExpr where-  show = pretty--instance Show TermExpr where-  show = pretty--instance Show SymbolExpr where-  show = pretty--instance {-# OVERLAPPING #-} Show (Index ScalarData) where-  show (Sup i)    = "~" ++ pretty' i-  show (Sub i)    = "_" ++ pretty' i-  show (SupSub i) = "~_" ++ pretty' i-  show (DF _ _)   = ""-  show (User i)   = "|" ++ pretty' i

@@ -1,128 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--{- |-Module      : Language.Egison.Math.Expr-Licence     : MIT--This module implements the normalization of polynomials. Normalization rules-for particular mathematical functions (such as sqrt and sin/cos) are defined-in Rewrite.hs.--}--module Language.Egison.Math.Normalize-  ( mathNormalize'-  , termsGcd-  , mathDivideTerm-  ) where--import           Control.Egison--import           Language.Egison.Math.Expr---mathNormalize' :: ScalarData -> ScalarData-mathNormalize' = mathDivide . mathRemoveZero . mathFold . mathRemoveZeroSymbol--termsGcd :: [TermExpr] -> TermExpr-termsGcd ts@(_:_) =-  foldl1 (\(Term a xs) (Term b ys) -> Term (gcd a b) (monoGcd xs ys)) ts- where-  monoGcd :: Monomial -> Monomial -> Monomial-  monoGcd [] _ = []-  monoGcd ((x, n):xs) ys =-    case f (x, n) ys of-      (_, 0) -> monoGcd xs ys-      (z, m) -> (z, m) : monoGcd xs ys--  f :: (SymbolExpr, Integer) -> Monomial -> (SymbolExpr, Integer)-  f (x, _) [] = (x, 0)-  f (Quote x, n) ((Quote y, m):ys)-    | x == y            = (Quote x, min n m)-    | x == mathNegate y = (Quote x, min n m)-    | otherwise         = f (Quote x, n) ys-  f (x, n) ((y, m):ys)-    | x == y    = (x, min n m)-    | otherwise = f (x, n) ys--mathDivide :: ScalarData -> ScalarData-mathDivide mExpr@(Div (Plus _) (Plus [])) = mExpr-mathDivide mExpr@(Div (Plus []) (Plus _)) = mExpr-mathDivide (Div (Plus ts1) (Plus ts2)) =-  let z@(Term c zs) = termsGcd (ts1 ++ ts2) in-  case ts2 of-    [Term a _] | a < 0 -> Div (Plus (map (`mathDivideTerm` Term (-c) zs) ts1))-                              (Plus (map (`mathDivideTerm` Term (-c) zs) ts2))-    _                  -> Div (Plus (map (`mathDivideTerm` z) ts1))-                              (Plus (map (`mathDivideTerm` z) ts2))--mathDivideTerm :: TermExpr -> TermExpr -> TermExpr-mathDivideTerm (Term a xs) (Term b ys) =-  let (sgn, zs) = divMonomial xs ys in-  Term (sgn * div a b) zs- where-  divMonomial :: Monomial -> Monomial -> (Integer, Monomial)-  divMonomial xs [] = (1, xs)-  divMonomial xs ((y, m):ys) =-    match dfs (y, xs) (SymbolM, Multiset (SymbolM, Eql))-      -- Because we've applied |mathFold|, we can only divide the first matching monomial-      [ [mc| (quote $s, ($x & negQuote #s, $n) : $xss) ->-               let (sgn, xs') = divMonomial xss ys in-               let sgn' = if even m then 1 else -1 in-               if n == m then (sgn * sgn', xs')-                         else (sgn * sgn', (x, n - m) : xs') |]-      , [mc| (_, (#y, $n) : $xss) ->-               let (sgn, xs') = divMonomial xss ys in-               if n == m then (sgn, xs') else (sgn, (y, n - m) : xs') |]-      , [mc| _ -> divMonomial xs ys |]-      ]--mathRemoveZeroSymbol :: ScalarData -> ScalarData-mathRemoveZeroSymbol (Div (Plus ts1) (Plus ts2)) =-  let ts1' = map (\(Term a xs) -> Term a (filter p xs)) ts1-      ts2' = map (\(Term a xs) -> Term a (filter p xs)) ts2-   in Div (Plus ts1') (Plus ts2')-  where-    p (_, 0) = False-    p _      = True--mathRemoveZero :: ScalarData -> ScalarData-mathRemoveZero (Div (Plus ts1) (Plus ts2)) =-  let ts1' = filter (\(Term a _) -> a /= 0) ts1 in-  let ts2' = filter (\(Term a _) -> a /= 0) ts2 in-    case ts1' of-      [] -> Div (Plus []) (Plus [Term 1 []])-      _  -> Div (Plus ts1') (Plus ts2')--mathFold :: ScalarData -> ScalarData-mathFold = mathTermFold . mathSymbolFold---- x^2 y x -> x^3 y-mathSymbolFold :: ScalarData -> ScalarData-mathSymbolFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (map f ts1)) (Plus (map f ts2))- where-  f :: TermExpr -> TermExpr-  f (Term a xs) =-    let (sgn, ys) = g xs in Term (sgn * a) ys-  g :: Monomial -> (Integer, Monomial)-  g [] = (1, [])-  g ((x, m):xs) =-    match dfs (x, xs) (SymbolM, Multiset (SymbolM, Eql))-      [ [mc| (quote $s, (negQuote #s, $n) : $xs) ->-               let (sgn, ys) = g ((x, m + n) : xs) in-               if even n then (sgn, ys) else (- sgn, ys) |]-      , [mc| (_, (#x, $n) : $xs) -> g ((x, m + n) : xs) |]-      , [mc| _ -> let (sgn', ys) = g xs in (sgn', (x, m):ys) |]-      ]---- x^2 y + x^2 y -> 2 x^2 y-mathTermFold :: ScalarData -> ScalarData-mathTermFold (Div (Plus ts1) (Plus ts2)) = Div (Plus (f ts1)) (Plus (f ts2))- where-  f :: [TermExpr] -> [TermExpr]-  f [] = []-  f (t:ts) =-    match dfs (t, ts) (TermM, Multiset TermM)-      [ [mc| (term $a $xs, term $b (equalMonomial $sgn #xs) : $tss) ->-               f (Term (sgn * a + b) xs : tss) |]-      , [mc| _ -> t : f ts |]-      ]

@@ -4,264 +4,377 @@ Module      : Language.Egison.Math.Rewrite Licence     : MIT -This module implements rewrite rules for common mathematical functions.+Residual mathematical rewrite rules kept in Haskell.++Remaining functions:+  - casRewriteDd : merge polynomial terms with same FunctionData factor.+    The equivalent declare-rule poly pattern is too expensive for complex+    differential-form samples (e.g. riemann-curvature-tensor-of-S2xS3).+  - casRewriteSqrt : sqrt power reduction and sqrt pair merging.+    Ported back from declare rule (G6 of design/cas-simplification.md):+    the Egison-level term rules paid a pattern-match attempt on every+    term of every sqrt-carrying value per normalization, making+    arithmetic on such values ~20x slower (thurston.egi's bottleneck).+  - casRewriteExp : exp power reduction and exp product merging+    ((exp a)^n -> exp (n a), exp a * exp b -> exp (a+b)), ported back+    for the same reason (an identical 60-operation fold on+    exp-carrying operands measured 20.7s under the declare rules).+    The value rules (exp 0 = 1, exp 1 = e, exp (n i pi) = (-1)^n)+    stay in the library.++Migrated to declare rule (and removed):+  - casRewriteI, casRewriteW, casRewriteLog+  - casRewritePower, casRewriteRt, casRewriteRtu -}  module Language.Egison.Math.Rewrite-  ( rewriteSymbol+  ( casRewriteSymbol   ) where  import           Control.Egison -import           Language.Egison.Math.Arith-import           Language.Egison.Math.Expr-import           Language.Egison.Math.Normalize-import {-# SOURCE #-} Language.Egison.Data (WHNFData)+import           Language.Egison.Math.CAS +-- | Apply rewrite rules to a CASValue.+casRewriteSymbol :: CASValue -> CASValue+casRewriteSymbol = casRewriteDd . casRewriteSqrt . casRewriteExp -rewriteSymbol :: ScalarData -> ScalarData-rewriteSymbol =-  foldl1 (\acc f -> f . acc)-    [ rewriteI-    , rewriteW-    , rewriteLog---    , rewriteSinCos-    , rewriteExp-    , rewritePower-    , rewriteSqrt-    , rewriteRt-    , rewriteRtu-    , rewriteDd-    ]+-- | Rewrite sqrt factors of every term (top level of the value, the+-- same scope as casRewriteDd; inner values were normalized when they+-- were constructed):+--+--   1. Power reduction: (sqrt a)^n with |n| >= 2 becomes+--      a^q * (sqrt a)^r with q = quot n 2 and r = n - 2q in {-1,0,1}+--      (matching the power-evaluation path's normal form).+--   2. Pair merge: sqrt a * sqrt b (both with exponent 1) merges to+--      sqrt (a*b), and the square part of a single-term product is+--      extracted: sqrt 2 * sqrt 8 = sqrt 16 = 4,+--      sqrt (2x) * sqrt (2y) = 2 * sqrt (x y),+--      sqrt x * sqrt (x y^2) = x y.  Multi-term (polynomial) products+--      stay under the sqrt: sqrt (x+1) * sqrt (x-1) = sqrt (x^2-1).+--+-- Fast path: values none of whose terms need sqrt work (see+-- termNeedsSqrtWork) are returned unchanged, without any rebuilding.+casRewriteSqrt :: CASValue -> CASValue+casRewriteSqrt = go (100 :: Int)+ where+  -- Iterate to a fixpoint (like the old applyRuleFix): one rewrite+  -- pass can create new reducible shapes -- merging produces products+  -- whose casMult combines equal atoms into powers, and content+  -- splitting produces pairs that reproduce themselves identically+  -- (sqrt 2 * sqrt(-sqrt 5 - 5) merges and re-splits to the same+  -- pair, which the equality check turns into a fixpoint).+  go 0 v = v+  go fuel v =+    let v' = rewriteSqrtOnce v+    in if v' == v then v else go (fuel - 1) v' -mapTerms :: (TermExpr -> TermExpr) -> ScalarData -> ScalarData-mapTerms f (Div (Plus ts1) (Plus ts2)) =-  Div (Plus (map f ts1)) (Plus (map f ts2))+rewriteSqrtOnce :: CASValue -> CASValue+rewriteSqrtOnce (CASFrac num denom)+  | valueNeedsSqrtWork num || valueNeedsSqrtWork denom =+      casDivide (rewriteSqrtPart num) (rewriteSqrtPart denom)+rewriteSqrtOnce v@(CASPoly _)+  | valueNeedsSqrtWork v = rewriteSqrtPart v+rewriteSqrtOnce v = v -mapTerms' :: (TermExpr -> ScalarData) -> ScalarData -> ScalarData-mapTerms' f (Div (Plus ts1) (Plus ts2)) =-  mathDiv (foldl mathPlus (Div (Plus []) (Plus [Term 1 []])) (map f ts1)) (foldl mathPlus (Div (Plus []) (Plus [Term 1 []])) (map f ts2))+-- | Fast path: a term needs sqrt work if it has a sqrt factor with+-- |exponent| >= 2, at least two sqrt factors with exponent 1, or a+-- nested value (an application argument, a quoted expression, or a+-- level-4 coefficient) that needs work itself -- the old declare-rule+-- versions recursed into those via mapTermAll, and nested-radical+-- reductions such as sqrt 5 * sqrt(-5-2 sqrt 5) * sqrt(-5+2 sqrt 5) = 5+-- depend on it.  Terms with a lone top-level (sqrt a)^(+-1) factor and+-- quiet insides -- the common shape in curvature-style values -- are+-- skipped without any rebuilding, which is the point of the port.+termNeedsSqrtWork :: CASTerm -> Bool+termNeedsSqrtWork (CASTerm c mono) = go 0 mono || valueNeedsSqrtWork c+ where+  go :: Int -> Monomial -> Bool+  go ones ((sym, n) : rest) = case sqrtRadicand sym of+    Just _+      | abs n >= 2       -> True+      | n == 1 && ones >= 1 -> True+      | n == 1           -> symNeedsSqrtWork sym || go 1 rest+      | otherwise        -> symNeedsSqrtWork sym || go ones rest+    Nothing              -> symNeedsSqrtWork sym || go ones rest+  go _ [] = False -mapPolys :: (PolyExpr -> PolyExpr) -> ScalarData -> ScalarData-mapPolys f (Div p1 p2) = Div (f p1) (f p2)+symNeedsSqrtWork :: SymbolExpr -> Bool+symNeedsSqrtWork = symNeedsWorkWith valueNeedsSqrtWork -rewriteI :: ScalarData -> ScalarData-rewriteI = mapTerms f- where-  f term@(Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (symbol #"i", $k) : $xss ->-              if even k-                then Term (a * (-1) ^ (quot k 2)) xss-                else Term (a * (-1) ^ (quot k 2)) ((Symbol "" "i" [], 1) : xss) |]-      , [mc| _ -> term |]-      ]+valueNeedsSqrtWork :: CASValue -> Bool+valueNeedsSqrtWork (CASFrac n d) = valueNeedsSqrtWork n || valueNeedsSqrtWork d+valueNeedsSqrtWork (CASPoly ts)  = any termNeedsSqrtWork ts+valueNeedsSqrtWork _             = False -rewriteW :: ScalarData -> ScalarData-rewriteW = mapPolys g . mapTerms f- where-  f term@(Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (symbol #"w", $k & ?(>= 3)) : $xss ->-               Term a ((Symbol "" "w" [], k `mod` 3) : xss) |]-      , [mc| _ -> term |]-      ]-  g poly@(Plus ts) =-    match dfs ts (Multiset TermM)-      [ [mc| term $a ((symbol #"w", #2) : $mr) :-             term $b ((symbol #"w", #1) : #mr) : $pr ->-               g (Plus (Term (-a) mr :-                        Term (b - a) ((Symbol "" "w" [], 1) : mr) : pr)) |]-      , [mc| _ -> poly |]-      ]+-- | Rewrite the terms that need it and re-combine.  Combination goes+-- through casPlus/casDivide (not a raw CASPoly rebuild) because a+-- negative radicand power over a polynomial radicand produces a+-- genuine fraction: (sqrt (x+1))^-2 = 1/(x+1).+rewriteSqrtPart :: CASValue -> CASValue+rewriteSqrtPart (CASPoly ts) =+  let changed   = filter termNeedsSqrtWork ts+      unchanged = filter (not . termNeedsSqrtWork) ts+  in foldl casPlus (casNormalizePoly unchanged) (map rewriteSqrtTerm changed)+rewriteSqrtPart v = v -rewriteLog :: ScalarData -> ScalarData-rewriteLog = mapTerms f- where-  f term@(Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply1 #"log" _ zero, _) : _ -> Term 0 [] |]-      , [mc| (apply1 #"log" _ (singleTerm _ #1 [(symbol #"e", $n)]), _) : $xss ->-              Term (n * a) xss |]-      , [mc| _ -> term |]-      ]+-- | The argument of a unary application factor of the named function.+applyArg1 :: String -> SymbolExpr -> Maybe CASValue+applyArg1 name (Apply1 fh a) = case fh of+  CASFactor (QuoteFunction w)+    | prettyFunctionName w == Just name -> Just a+  CASPoly [CASTerm (CASInteger 1) [(QuoteFunction w, 1)]]+    | prettyFunctionName w == Just name -> Just a+  _ -> Nothing+applyArg1 _ _ = Nothing -makeApply :: WHNFData -> [ScalarData] -> SymbolExpr-makeApply f args =-  makeApplyExpr (SingleSymbol (QuoteFunction f)) args+-- | The radicand of a sqrt application factor, if it is one.+sqrtRadicand :: SymbolExpr -> Maybe CASValue+sqrtRadicand = applyArg1 "sqrt" -rewriteExp :: ScalarData -> ScalarData-rewriteExp = mapTerms f- where-  f term@(Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply1 #"exp" _ zero, _) : $xss ->-               f (Term a xss) |]-      , [mc| (apply1 #"exp" _ (singleTerm #1 #1 []), _) : $xss ->-               f (Term a ((Symbol "" "e" [], 1) : xss)) |]-      , [mc| (apply1 #"exp" _ (singleTerm $n #1 [(symbol #"i", #1), (symbol #"π", #1)]), _) : $xss ->-               f (Term ((-1) ^ n * a) xss) |]-      , [mc| (apply1 #"exp" $expWhnf $x, $n & ?(>= 2)) : $xss ->-               f (Term a ((makeApply expWhnf [mathScalarMult n x], 1) : xss)) |]-      , [mc| (apply1 #"exp" $expWhnf $x, #1) : (apply1 #"exp" _ $y, #1) : $xss ->-               f (Term a ((makeApply expWhnf [mathPlus x y], 1) : xss)) |]-      , [mc| _ -> term |]-      ]+-- | Generic traversals shared by the factor rewriters: does any+-- nested value (application argument, quoted expression) satisfy the+-- check / rewrite every nested value.  Each rewriter recurses only+-- into itself, matching the old per-rule mapTermAll recursion.+symNeedsWorkWith :: (CASValue -> Bool) -> SymbolExpr -> Bool+symNeedsWorkWith p (Apply1 _ a)       = p a+symNeedsWorkWith p (Apply2 _ a b)     = p a || p b+symNeedsWorkWith p (Apply3 _ a b c)   = p a || p b || p c+symNeedsWorkWith p (Apply4 _ a b c d) = p a || p b || p c || p d+symNeedsWorkWith p (Quote q)          = p q+symNeedsWorkWith _ _                  = False -rewritePower :: ScalarData -> ScalarData-rewritePower = mapTerms f- where-  f term@(Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply1 #"^" _ (singleTerm #1 #1 []), _) : $xss -> f (Term a xss) |]-      , [mc| (apply2 #"^" $powerWhnf $x $y, $n & ?(>= 2)) : $xss ->-               f (Term a ((makeApply powerWhnf [x, mathScalarMult n y], 1) : xss)) |]-      , [mc| (apply2 #"^" $powerWhnf $x $y, #1) : (apply2 #"^" _ #x $z, #1) : $xss ->-               f (Term a ((makeApply powerWhnf [x, mathPlus y z], 1) : xss)) |]-      , [mc| _ -> term |]-      ]+rewriteInsideSymWith :: (CASValue -> CASValue) -> SymbolExpr -> SymbolExpr+rewriteInsideSymWith f sym = case sym of+  Apply1 g a       -> Apply1 g (f a)+  Apply2 g a b     -> Apply2 g (f a) (f b)+  Apply3 g a b c   -> Apply3 g (f a) (f b) (f c)+  Apply4 g a b c d -> Apply4 g (f a) (f b) (f c) (f d)+  Quote q          -> Quote (f q)+  _                -> sym -rewriteSinCos :: ScalarData -> ScalarData-rewriteSinCos = h . mapTerms (g . f)+-- | Rewrite the sqrt factors of one term.  Returns a CASValue because+-- extracted radicand powers can be polynomials.  Nested values+-- (application arguments, quoted expressions, level-4 coefficients)+-- are rewritten first, bottom-up, matching the old mapTermAll+-- recursion of the declare-rule versions.+rewriteSqrtTerm :: CASTerm -> CASValue+rewriteSqrtTerm (CASTerm c0 mono0) =+  let c    = casRewriteSqrt c0+      mono = [ (rewriteInsideSym sym, n) | (sym, n) <- mono0 ]+      -- 1. power reduction on every factor with |n| >= 2+      (powerOuts, mono1) = foldr powerStep ([], []) mono+      powerStep (sym, n) (outs, ms) = case sqrtRadicand sym of+        Just a | abs n >= 2 ->+          let q = n `quot` 2+              r = n - 2 * q+          in (casPower a q : outs, if r == 0 then ms else (sym, r) : ms)+        _ -> (outs, (sym, n) : ms)+      -- 2. pair merge on the remaining exponent-1 sqrt factors+      (sqrtOnes, others) = partitionSqrtOnes mono1+      base = CASPoly [CASTerm c others]+      merged = case sqrtOnes of+        ((sym0, _) : _ : _) ->+          let radicands = map snd sqrtOnes+              product'  = casRewriteSqrt (foldr1 casMult radicands)+              (outside, insides) = splitSquarePart product'+              sqrtAtom r = case sym0 of+                Apply1 fh _ -> CASPoly [CASTerm (CASInteger 1) [(Apply1 fh r, 1)]]+                _           -> error "rewriteSqrtTerm: non-Apply1 sqrt factor"+          in outside : map sqrtAtom insides+        [(sym0, _)] -> [CASPoly [CASTerm (CASInteger 1) [(sym0, 1)]]]+        []          -> []+  in foldl casMult base (powerOuts ++ merged)  where-  f term@(Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply1 #"sin" _ zero, _) : _ -> Term 0 [] |]-      , [mc| (apply1 #"sin" _ (singleTerm _ #1 [(symbol #"π", #1)]), _) : _ ->-               Term 0 [] |]-      , [mc| (apply1 #"sin" _ (singleTerm $n #2 [(symbol #"π", #1)]), $m) : $xss ->-              Term (a * (-1) ^ (div (abs n - 1) 2) * m) xss |]-      , [mc| _ -> term |]-      ]-  g term@(Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply1 #"cos" _ zero, _) : $xss -> Term a xss |]-      , [mc| (apply1 #"cos" _ (singleTerm _ #2 [(symbol #"π", #1)]), _) : _ ->-              Term 0 [] |]-      , [mc| (apply1 #"cos" _ (singleTerm $n #1 [(symbol #"π", #1)]), $m) : $xss ->-               Term (a * (-1) ^ (abs n * m)) xss |]-      , [mc| _ -> term |]-      ]-  h (Div poly1@(Plus ts1) poly2@(Plus ts2)) =-    match dfs (ts1, ts2) (Multiset TermM, Multiset TermM)-      [ [mc| ((term $a ((apply1 #"cos" $cosWhnf $x, #2) : $mr)) : (term $b ((apply1 #"sin" $sinWhnf #x, #2) : #mr)) : $pr, _) ->-              h (Div (Plus (Term a mr : Term (b - a) ((makeApply sinWhnf [x], 2) : mr) : pr)) poly2) |]-      , [mc| ((term $a ((apply1 #"cos" $cosWhnf $x, #2) : $mr)) : $pr1, (term _ ((apply1 #"sin" $sinWhnf #x, #2) : #mr)) : _) ->-              h (Div (Plus (Term a mr : Term (- a) ((makeApply sinWhnf [x], 2) : mr) : pr1)) poly2) |]-      , [mc| _ -> Div poly1 poly2 |]-      ]+  partitionSqrtOnes = foldr step ([], [])+   where+    step (sym, 1) (sq, rest) = case sqrtRadicand sym of+      Just a  -> ((sym, a) : sq, rest)+      Nothing -> (sq, (sym, 1) : rest)+    step f (sq, rest) = (sq, f : rest) --- Determine if a ScalarData is definitely negative--- Returns Just True if negative, Just False if non-negative, Nothing if unknown-isNegativeScalar :: ScalarData -> Maybe Bool-isNegativeScalar (Div (Plus terms) (Plus [Term d []]))-  | d > 0 = analyzeTerms terms-  | d < 0 = fmap not (analyzeTerms terms)- where-  analyzeTerms ts-    | all (\(Term a _) -> a < 0) ts = Just True-    | all (\(Term a _) -> a > 0) ts = Just False-    | otherwise =-      -- Two-term case: a + b*sqrt(n), compare a^2 with b^2*n-      match dfs ts (Multiset TermM)-        [ [mc| term $a [] :-               term $b ((apply1 #"sqrt" _ (singleTerm $n #1 []), #1) : []) :-               [] ->-                 if n > 0-                 then let lhs = a * a; rhs = b * b * n-                      in if lhs > rhs then Just (a < 0)-                         else if lhs < rhs then Just (b < 0)-                         else Just False-                 else Nothing |]-        , [mc| _ -> Nothing |]-        ]-isNegativeScalar _ = Nothing+  rewriteInsideSym = rewriteInsideSymWith casRewriteSqrt --- Find a pair of sqrts in a monomial whose product simplifies to a single term.--- Uses matchAll to enumerate all sqrt pairs, avoiding DFS ordering issues.--- We apply rewriteSqrt to the product because mathMult alone does not simplify--- sqrt(x)^2 to x, which is needed for products like (-5-2√5)*(-5+2√5).-findSqrtPairToMerge :: Monomial -> Maybe (WHNFData, ScalarData, Monomial, Integer)-findSqrtPairToMerge xs =-  case results of-    (r:_) -> Just r-    []    -> Nothing+-- | Split a merged radicand into (outside, inside radicands) with+-- value = outside^2 * product(insides), extracting square content and+-- canonicalizing the atom forms:+--+--   * single-term radicand: extract the square part of the integer+--     coefficient and the even exponents (sqrt 16 = 4,+--     sqrt (4 x^2 y) = 2 x sqrt y); the remainder stays as ONE atom.+--   * multi-term radicand: extract the integer content's square part,+--     and split the squarefree content off as its OWN integer sqrt+--     atom, leaving a content-free polynomial radicand.  This matches+--     the stable form the old declare-rule + lib-sqrt round trip+--     converged to (sqrt 5 * sqrt(-10 sqrt 5 - 50) =+--     5 * sqrt(-2 sqrt 5 - 10)); without it, algebraically related+--     atoms appear in several content forms and sums that should+--     cancel (5th roots of unity, mini-test 117) do not.+--+-- Anything unsupported stays entirely inside (value-safe).+splitSquarePart :: CASValue -> (CASValue, [CASValue])+splitSquarePart (CASPoly [CASTerm (CASInteger m) mono])+  | m >= 0 =+      let (s, m') = integerSquarePart m+          outsideFactors = [ (sym, k `div` 2) | (sym, k) <- mono, k `div` 2 /= 0 ]+          insideFactors  = [ (sym, k `mod` 2) | (sym, k) <- mono, k `mod` 2 /= 0 ]+          outside = CASPoly [CASTerm (CASInteger s) outsideFactors]+          inside  = casNormalizePoly [CASTerm (CASInteger m') insideFactors]+      in (outside, if inside == CASInteger 1 then [] else [inside])+splitSquarePart (CASInteger m)+  | m >= 0 =+      let (s, m') = integerSquarePart m+      in (CASInteger s, if m' == 1 then [] else [CASInteger m'])+splitSquarePart (CASPoly ts@(_ : _ : _))+  | Just coeffs <- mapM intCoeff ts+  , let g = foldr1 gcd (map abs coeffs)+  , g > 1 =+      let (s, g') = integerSquarePart g+          prim = casNormalizePoly+                   [ CASTerm (CASInteger (c `div` g)) mono | CASTerm (CASInteger c) mono <- ts ]+      in ( CASInteger s+         , (if g' == 1 then [] else [CASInteger g']) ++ [prim] )  where-  results =-    [ (whnf, simplified, xss, sign)-    | (whnf, x, y, xss) <- matchAll dfs xs (Multiset (SymbolM, Eql))-        [ [mc| (apply1 #"sqrt" $whnf $x, #1) :-               (apply1 #"sqrt" _ $y, #1) : $xss ->-                 (whnf, x, y, xss) |] ]-    , let simplified = rewriteSqrt (mathMult x y)-    , isSingleTermScalar simplified-    , let sign = case (isNegativeScalar x, isNegativeScalar y) of-                   (Just True, Just True) -> -1-                   _                      -> 1-    ]-  isSingleTermScalar (Div (Plus [_]) (Plus [_])) = True-  isSingleTermScalar _ = False+  intCoeff (CASTerm (CASInteger c) _) = Just c+  intCoeff _                          = Nothing+splitSquarePart v = (CASInteger 1, [v]) -rewriteSqrt :: ScalarData -> ScalarData-rewriteSqrt = mapTerms' f+-- | Largest s with s^2 dividing m (m >= 0), by trial division with a+-- divisor cap: square factors hiding behind primes above the cap are+-- left inside (value-safe, just less extraction).+integerSquarePart :: Integer -> (Integer, Integer)+integerSquarePart m0 = go m0 2  where-  f (Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply1 #"sqrt" $sqrtWhnf $x, ?(> 1) & $k) : $xss ->-               rewriteSqrt-                 (mathMult (SingleTerm a ((makeApply sqrtWhnf [x], k `mod` 2) : xss))-                           (mathPower x (div k 2))) |]-      , [mc| (apply1 #"sqrt" $sqrtWhnf (singleTerm $n #1 $x), #1) :-               (apply1 #"sqrt" _ (singleTerm $m #1 $y), #1) : $xss ->-             let d@(Term c z) = termsGcd [Term n x, Term m y]-                 Term n' x' = mathDivideTerm (Term n x) d-                 Term m' y' = mathDivideTerm (Term m y) d-                 in case (n' * m', Term n' x', Term m' y') of-                      (1, Term _ [], Term _ []) -> mathMult (SingleTerm c z) (SingleTerm a xss)-                      (_, _, _) -> mathMult (SingleTerm c z) (SingleTerm a ((makeApply sqrtWhnf [SingleTerm (n' * m') (x' ++ y')], 1) : xss)) |]-      , [mc| _ -> case findSqrtPairToMerge xs of-                    Just (whnf, product, remaining, sign) ->-                      rewriteSqrt (SingleTerm (sign * a) ((makeApply whnf [product], 1) : remaining))-                    Nothing -> SingleTerm a xs |]-      ]+  go :: Integer -> Integer -> (Integer, Integer)+  cap = 1000000+  go m p+    | p > cap || p * p > m = (1, m)+    | m `mod` p == 0 =+        let (e, m')   = strip m p 0+            (s, rest) = go m' (p + 1)+        in (p ^ (e `div` 2) * s, p ^ (e `mod` 2) * rest)+    | otherwise = go m (p + 1)+  strip :: Integer -> Integer -> Integer -> (Integer, Integer)+  strip m p e+    | m `mod` p == 0 = strip (m `div` p) p (e + 1)+    | otherwise      = (e, m) -rewriteRt :: ScalarData -> ScalarData-rewriteRt = mapTerms' f+-- | Rewrite exp factors of every term:+--+--   1. Power reduction: (exp a)^n with n /= 1 becomes exp (n a).+--   2. Product merge: all exp factors of a term merge into one,+--      exp a * exp b = exp (a+b); a zero total collapses to 1+--      (exp x * exp (-x) = 1).+--+-- One pass per term suffices (the merge is closed: it produces at+-- most one exp factor with exponent 1).  Nested values are rewritten+-- first, like casRewriteSqrt.  The value rules exp 0 = 1, exp 1 = e,+-- and exp (n i pi) = (-1)^n stay in the library and fire on the+-- merged atom as before.+casRewriteExp :: CASValue -> CASValue+casRewriteExp (CASFrac num denom)+  | valueNeedsExpWork num || valueNeedsExpWork denom =+      casDivide (rewriteExpPart num) (rewriteExpPart denom)+casRewriteExp v@(CASPoly _)+  | valueNeedsExpWork v = rewriteExpPart v+casRewriteExp v = v++expArg :: SymbolExpr -> Maybe CASValue+expArg = applyArg1 "exp"++-- | A term needs exp work if it has an exp factor with exponent /= 1,+-- at least two exp factors, or nested work.+termNeedsExpWork :: CASTerm -> Bool+termNeedsExpWork (CASTerm c mono) = go 0 mono || valueNeedsExpWork c  where-  f (Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply2 #"rt" _ (singleTerm $n #1 []) $x & $rtnx, ?(>= n) & $k) : $xss ->-               mathMult (SingleTerm a ((rtnx, k `mod` n) : xss))-                        (mathPower x (div k n)) |]-      , [mc| _ -> SingleTerm a xs |]-      ]+  go :: Int -> Monomial -> Bool+  go ones ((sym, n) : rest) = case expArg sym of+    Just _+      | n /= 1    -> True+      | ones >= 1 -> True+      | otherwise -> symNeedsWorkWith valueNeedsExpWork sym || go 1 rest+    Nothing       -> symNeedsWorkWith valueNeedsExpWork sym || go ones rest+  go _ [] = False -rewriteRtu :: ScalarData -> ScalarData-rewriteRtu = mapTerms' g . mapTerms f+valueNeedsExpWork :: CASValue -> Bool+valueNeedsExpWork (CASFrac n d) = valueNeedsExpWork n || valueNeedsExpWork d+valueNeedsExpWork (CASPoly ts)  = any termNeedsExpWork ts+valueNeedsExpWork _             = False++rewriteExpPart :: CASValue -> CASValue+rewriteExpPart (CASPoly ts) =+  let changed   = filter termNeedsExpWork ts+      unchanged = filter (not . termNeedsExpWork) ts+  in foldl casPlus (casNormalizePoly unchanged) (map rewriteExpTerm changed)+rewriteExpPart v = v++rewriteExpTerm :: CASTerm -> CASValue+rewriteExpTerm (CASTerm c0 mono0) =+  let c    = casRewriteExp c0+      mono = [ (rewriteInsideSymWith casRewriteExp sym, n) | (sym, n) <- mono0 ]+      (exps, others) = foldr step ([], []) mono+      step (sym, n) (es, ms) = case expArg sym of+        Just a  -> ((sym, casMult (CASInteger n) a) : es, ms)+        Nothing -> (es, (sym, n) : ms)+      base = CASPoly [CASTerm c others]+  in case exps of+       [] -> base+       ((sym0, _) : _) ->+         let total = foldr1 casPlus (map snd exps)+             atom = case sym0 of+               Apply1 fh _ -> CASPoly [CASTerm (CASInteger 1) [(Apply1 fh total, 1)]]+               _           -> error "rewriteExpTerm: non-Apply1 exp factor"+         in if casIsZero total+              then base+              else casMult base atom++-- | Rewrite dd (differential): merge polynomial terms whose monomial shares+-- the same FunctionData factor (same `g`, `args`, exponent, and rest of+-- monomial). Kept in Haskell because the equivalent+-- `declare rule auto poly` (multi-term, same-binding) is too expensive for+-- complex differential-form samples (e.g. riemann-curvature-tensor-of-S2xS3).+--+-- Fast path: if the value contains no FunctionData factor anywhere, the+-- pattern can't fire — return the value unchanged. This avoids the+-- per-mathNormalize-call overhead of `rewriteDdPoly`'s multi-term matcher+-- on the vast majority of values that have no `Function _ _` factors.+casRewriteDd :: CASValue -> CASValue+casRewriteDd v+  | not (casHasFunctionData v) = v+casRewriteDd (CASFrac num denom) =+  CASFrac (casNormalizePoly (rewriteDdPoly (extractTerms num)))+         (casNormalizePoly (rewriteDdPoly (extractTerms denom)))  where-  f term@(Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply1 #"rtu" _ (singleTerm $n #1 []) & $rtun, ?(>= n) & $k) : $r ->-               Term a ((rtun, k `mod` n) : r) |]-      , [mc| _ -> term |]-      ]-  g (Term a xs) =-    match dfs xs (Multiset (SymbolM, Eql))-      [ [mc| (apply1 #"rtu" _ (singleTerm $n #1 []) & $rtun, ?(== n - 1)) : $mr ->-               mathMult-                 (foldl mathMinus (SingleTerm (-1) []) (map (\k -> SingleTerm 1 [(rtun, k)]) [1..(n-2)]))-                 (g (Term a mr)) |]-      , [mc| _ -> SingleTerm a xs |]-      ]+  extractTerms (CASPoly ts) = ts+  extractTerms (CASInteger n) = [CASTerm (CASInteger n) []]+  extractTerms _ = []+casRewriteDd (CASPoly ts) = casNormalizePoly (rewriteDdPoly ts)+casRewriteDd v = v -rewriteDd :: ScalarData -> ScalarData-rewriteDd (Div (Plus p1) (Plus p2)) =-  Div (Plus (rewriteDdPoly p1)) (Plus (rewriteDdPoly p2))+-- | True if the CASValue contains any `FunctionData` factor anywhere in+-- its tree.+casHasFunctionData :: CASValue -> Bool+casHasFunctionData = goV  where-  rewriteDdPoly poly =-    match dfs poly (Multiset TermM)-      [ [mc| term $a (($f & func $g $args, $n) : $mr) :-               term $b ((func #g #args, #n) : #mr) : $pr ->-                 rewriteDdPoly (Term (a + b) ((f, n) : mr) : pr) |]-      , [mc| _ -> poly |]-      ]+  goV (CASInteger _)  = False+  goV (CASFactor sym) = goSym sym+  goV (CASPoly terms) = any goTerm terms+  goV (CASFrac n d)   = goV n || goV d+  goTerm (CASTerm coeff mono) = goV coeff || any (goSym . fst) mono+  goSym (FunctionData {})  = True+  goSym (Apply1 f a)        = goV f || goV a+  goSym (Apply2 f a b)      = goV f || goV a || goV b+  goSym (Apply3 f a b c)    = goV f || goV a || goV b || goV c+  goSym (Apply4 f a b c d)  = goV f || goV a || goV b || goV c || goV d+  goSym (Quote v)           = goV v+  goSym (Symbol _ _ _)      = False+  goSym (QuoteFunction _)   = False++rewriteDdPoly :: [CASTerm] -> [CASTerm]+rewriteDdPoly poly =+  match dfs poly (Multiset CASTermM)+    [ [mc| casTerm' $a (($f & casFunc $g $args, $n) : $mr) :+           casTerm' $b ((casFunc #g #args, #n) : #mr) : $pr ->+             rewriteDdPoly (CASTerm (casPlus a b) ((f, n) : mr) : pr) |]+    , [mc| _ -> poly |]+    ]